diff options
154 files changed, 4593 insertions, 952 deletions
diff --git a/.travis-ci.sh b/.travis-ci.sh index aa37577ba9..1ecd8af3c2 100644 --- a/.travis-ci.sh +++ b/.travis-ci.sh @@ -10,26 +10,100 @@ # # ######################################################################### -case $XARCH in -i386) - ./configure - make world.opt - sudo make install - (cd testsuite && make all) - mkdir external-packages - cd external-packages - git clone git://github.com/ocaml/camlp4 - (cd camlp4 && ./configure && make && sudo make install) - git clone git://github.com/ocaml/opam - (cd opam && ./configure && make lib-ext && make && sudo make install) - git config --global user.email "some@name.com" - git config --global user.name "Some Name" - opam init -y -a git://github.com/ocaml/opam-repository - opam install -y oasis - # opam pin add -y utop git://github.com/diml/utop - ;; -*) - echo unknown arch - exit 1 - ;; +PREFIX=~/local + +BuildAndTest () { + case $XARCH in + i386) + echo<<EOF +------------------------------------------------------------------------ +This test builds the OCaml compiler distribution with your pull request, +runs its testsuite, and then tries to install some important OCaml softare +(currently camlp4, opam and oasis) on top of it. + +Failing to build the compiler distribution, or testsuite failures are +critical errors that must be understood and fixed before your pull +request can be merged. The later installation attempts try to run +bleeding-edge software, and failures can sometimes be out of your +control. +------------------------------------------------------------------------ +EOF + mkdir -p $PREFIX + ./configure --prefix $PREFIX + export PATH=$PREFIX/bin:$PATH + make world.opt + make install + (cd testsuite && make all) + mkdir external-packages + cd external-packages + git clone git://github.com/ocaml/camlp4 + (cd camlp4 && + ./configure --bindir=$PREFIX/bin --libdir=$PREFIX/lib/ocaml \ + --pkgdir=$PREFIX/lib/ocaml && \ + make && make install) + git clone git://github.com/ocaml/opam + (cd opam && ./configure --prefix $PREFIX &&\ + make lib-ext && make && make install) + git config --global user.email "some@name.com" + git config --global user.name "Some Name" + opam init -y -a git://github.com/ocaml/opam-repository + opam install -y oasis + # opam pin add -y utop git://github.com/diml/utop + ;; + *) + echo unknown arch + exit 1 + ;; + esac +} + +CheckChangesModified () { + echo<<EOF +------------------------------------------------------------------------ +This test checks that the Changes file has been modified by the pull +request. Most contributions should come with a message in the Changes +file, as described in our contributor documentation: + + https://github.com/ocaml/ocaml/blob/trunk/CONTRIBUTING.md#changelog + +Some very minor changes (typo fixes for example) may not need +a Changes entry, in which case it is acceptable for this test to fail. +------------------------------------------------------------------------ +EOF + # check that Changes has been modified + git diff $TRAVIS_COMMIT_RANGE --name-only --exit-code Changes > /dev/null \ + && exit 1 || echo pass +} + +CheckTestsuiteModified () { + echo<<EOF +------------------------------------------------------------------------ +This test checks that the OCaml testsuite has been modified by the +pull request. Any new feature should come with tests, bugs should come +with regression tests, and generally any change in behavior that can +be exercized by a test should come with a test or modify and existing +test. See our contributor documentation: + + https://github.com/ocaml/ocaml/blob/trunk/CONTRIBUTING.md#test-you-must + +Modifications that result in no change in observable behavior +(documentation contributions for example) can hardly be tested, in +which case it is acceptable for this test to fail. + +Note: the heuristic used by this test is extremely fragile; passing it +does *not* imply that your change is appropriately tested. +------------------------------------------------------------------------ +EOF + # check that at least a file in testsuite/ has been modified + git diff $TRAVIS_COMMIT_RANGE --name-only --exit-code testsuite > /dev/null \ + && exit 1 || echo pass +} + +case $CI_KIND in +build) BuildAndTest;; +changes) CheckChangesModified;; +tests) CheckTestsuiteModified;; +*) echo unknown CI kind + exit 1 + ;; esac diff --git a/.travis.yml b/.travis.yml index 93c47efa69..b0a323af8b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -10,7 +10,14 @@ # # ######################################################################### +sudo: false language: c script: bash -ex .travis-ci.sh -env: - - XARCH=i386 +matrix: + include: + - env: CI_KIND=build XARCH=i386 + - env: CI_KIND=changes + - env: CI_KIND=tests + allow_failures: + - env: CI_KIND=changes + - env: CI_KIND=tests @@ -16,7 +16,7 @@ Language features: constructors (Alain Frisch) - PR#6714: allow [@@ocaml.warning] on most structure and signature items: values, modules, module types - (Peter Zotov) + (whitequark) - GPR#26: support for "(type a b)" as syntactic sugar for "(type a) (type b)" (Gabriel Scherer) - GPR#42: short functor type syntax: "S -> T" for "functor (_ : S) -> T" @@ -46,6 +46,10 @@ Language features: attribute is applied on predefined exception constructors which take an purely informational (with no stability guarantee) message. (Alain Frisch) +- GPR#268: hexadecimal notation for floating-point literals + In OCaml source code, FP literals can be written using the hexadecimal + notation 0x<mantissa in hex>p<exponent> from ISO C99. + (Xavier Leroy) - GPR#173: [@inline] and [@inlined] attributes (for function declarations and call sites respectively) to control inlining (Pierre Chambart, Mark Shinwell) @@ -53,6 +57,12 @@ Language features: (Valentin Gatien-Baron, review by Jérémie Dimino) - PR#6806: Allow type annotations before the "->" in "fun <args> -> <expr>" (Valentin Gatien-Baron, review by Jérémie Dimino) +- GPR#282: change short-paths penalty heuristic to assign the same cost to + idents containing double underscores as to idents starting with an underscore + (Thomas Refis, Leo White) +- GPR#273: allow to get the extension slot of an extension constructor + by writing [%extension_constructor <path>] + (Jérémie Dimino) Compilers: - PR#4800: better compilation of tuple assignment (Gabriel Scherer and @@ -60,7 +70,7 @@ Compilers: - PR#6501: harden the native-code generator against certain uses of "%identity" (Xavier Leroy, report by Antoine Miné). - PR#6636: add --version option - (Peter Zotov) + (whitequark) - improve type-specialization of unapplied primitives (Frédéric Bour, review by Gabriel Scherer) - PR#6737: fix Typedtree attributes on (fun x -> body) expressions @@ -94,6 +104,12 @@ Compilers: (Mark Shinwell) - GPR#270: Make [transl_exception_constructor] generate [Immutable] blocks (Mark Shinwell) +- GPR#275: native-code generator for IBM z System running Linux. + In memoriam Gene Amdahl, 1922-2015. + (Bill O'Farrell, Tristan Amini, Xavier Leroy) +- GPR#282: relax short-paths safety check in presence of module aliases, take + penalty into account while building the printing map. + (Thomas Refis, Leo White) Runtime system: - PR#3612: allow allocating custom block with finalizers in the minor heap @@ -102,17 +118,21 @@ Runtime system: types {,u}int{32,64}. (Xavier Leroy) - PR#6760: closures evaluated in the toplevel can now be marshalled - (Peter Zotov, review by Jacques-Henri Jourdan) + (whitequark, review by Jacques-Henri Jourdan) - PR#6902, GPR#210: runtime emits a warning when finalizing an I/O channel which is still open (Alain Frisch, review by Damien Doligez) - Signal handling: for read-and-clear, use GCC/Clang atomic builtins if available. (Xavier Leroy) +- PR#6910, GPR#224: marshaling (output_value, input_value, et al) + now support marshaled data bigger than 4 Gb. (Xavier Leroy) - GPR#226: select higher levels of optimization for GCC and Clang when compiling the run-time system and C stub code. (Xavier Leroy) - GPR#262: Multiple GC roots per compilation unit (Pierre Chambart, Mark Shinwell, review by Damien Doligez) Standard library: +- PR#5197, GPR#63: Arg: allow flags such as --flag=arg as well as --flag arg + (Richard Jones) - PR#6017, PR#7034, GPR#267: More efficient ifprintf implementation (Jeremy Yallop, review by Gabriel Scherer) - PR#6316: Scanf.scanf failure on %u formats when reading big integers @@ -131,10 +151,13 @@ Standard library: (Christopher McAlpine) - PR#6645, GPR#174: Guarantee that Set.add, Set.remove, Set.filter return the original set if no change is required (Alain Frisch, - Mohamed Iguernelala) + Mohamed Iguernlala) +- GPR#175: Guarantee that Map.add, Map.remove, Map.filter + return the original map if no change is required. + (Mohamed Iguernlala) - PR#6694, PR#6695: deprecate functions using ISO-8859-1 character set in Char, Bytes, String and provide alternatives using US-ASCII. - (Peter Zotov) + (whitequark) - GPR#164: more efficient (branchless) implementation of Pervasives.compare specialized at type 'float'. (Vladimir Brankov) @@ -148,7 +171,12 @@ Standard library: (report and fix by Jeremy Yallop) - GPR#265: new implementation of Queue avoiding Obj.magic (Jérémie Dimino) +- GPR#268, GPR#303: '%h' and '%H' modifiers for printf and scanf to + support floating-point numbers in hexadecimal notation + (Xavier Leroy, Benoît Vaugon) - GPR#272: Switch classify_float to [@@unboxed] (Alain Frisch) +- Improve speed of classify_float by not going through fpclassify() + (Alain Frisch, Xavier Leroy) - GPR#277: Switch the following externals to [@@unboxed]: * {Nativeint,Int32,Int64}.{of,to}_float * Int{32,64}.float_of_bits @@ -170,28 +198,42 @@ Type system: Toplevel and debugger: - PR#6468: toplevel now supports backtraces if invoked with OCAMLRUNPARAM=b - (Peter Zotov and Jake Donham, + (whitequark and Jake Donham, review by Gabriel Scherer and Jacques-Henri Jourdan) +- PR#6935, GPR#298: crash in debugger when load_printer is given a directory + (Junsong Li, review by Gabriel Scherer) Other libraries: +- PR#4023 and GPR#68: add Unix.sleepf (sleep with sub-second resolution) + (Evgenii Lepikhin and Xavier Leroy) +* Protect Unix.sleep against interruptions by handled signals. + Before, a handled signal could cause Unix.sleep to return early. + Now, the sleep is restarted until the given time is elapsed. + (Xavier Leroy) - PR#6896: serious reimplementation of Big_int.float_of_big_int and Ratio.float_of_ratio, ensuring that the result is correctly rounded. (Xavier Leroy) - PR#7013: spurious wake-up in the Event module (Xavier Leroy) +- PR#7024: in documentation of Str regular expressions, clarify what + "end of line" means for "^" and "$" regexps. OCamlbuild: - PR#6794, PR#6809: pass package-specific include flags when building C files - (Jérémie Dimino, request by Peter Zotov) + (Jérémie Dimino, request by whitequark) - GPR#208: add "asm" tag to ocamlbuild to enable flag -S (ygrek) - Changed OCamlbuild's license to LGPLv2 with static linking exception. - GPR#219: speedup target-already-built builds (ygrek) +- PR#6605, GPR#117: use ocamlfind, if available, to discover camlp4 path + (Vincent Laporte) Bug fixes: - PR#3612: memory leak in bigarray read from file (Pierre Chambart, report by Gary Huber) +* PR#4166, PR#6956: force linking when calling external C primitives + (Jacques Garrigue, reports by Markus Mottl and Christophe Troestler) * PR#4539: change exception string raised when comparing functional values (Nicolas Braud-Santoni, report by Eric Cooper) - PR#4832: Filling bigarrays may block out runtime @@ -204,7 +246,7 @@ Bug fixes: (Jacques Garrigue, report by Sebastien Furic) - PR#5887: move the byterun/*.h headers to byterun/caml/*.h to avoid header name clashes - (Jérôme Vouillon and Adrien Nader and Peter Zotov) + (Jérôme Vouillon and Adrien Nader and whitequark) * PR#6081: ocaml should add script's directory to search path, not current directory (Thomas Leonard and Damien Doligez) @@ -264,8 +306,12 @@ Bug fixes: (report and fix by Patrick Star) - PR#7036: Module alias is not taken into account when checking module type compatibility (in a class type) (Jacques Garrigue) +- PR#7038: out of memory condition in caml_io_mutex_lock + (Xavier Leroy, report by Marc Lasson) - PR#7039: Unix.getsockname returns garbage for unnamed PF_UNIX sockets (Xavier Leroy) +- PR#7042 and GPR#295: CSE optimization confuses the FP literals +0.0 and -0.0 + (Xavier Leroy) - GPR#205: Clear caml_backtrace_last_exn before registering as root (report and fix by Frederic Bour) - GPR#220: minor -dsource error on recursive modules @@ -280,8 +326,12 @@ Bug fixes: (whitequark) - GPR#280: Fix stdlib dependencies for .p.cmx (Pierre Chambart, Mark Shinwell) +- GPR#283: Fix memory leaks in intern.c when OOM is raised + (Marc Lasson, review by Alain Frisch) Features wishes: +- PR#4518, GPR#29: change location format for reporting errors in ocamldoc + (Sergei Lebedev) - PR#4714: List.cons - PR#5418 (comments) : generate dependencies with $(CC) instead of gcc - PR#6167: OCAMLPARAM support for disabling PIC generation ("pic=0") @@ -319,8 +369,6 @@ Features wishes: - GPR#156, GPR#279: optimize caml_frame_descriptors realloc (dynlink speedup) (Pierre Chambart, Alain Frisch, review by François Bobot, Xavier Leroy and Damien Doligez) -- GPR#171: allow custom warning printers / catchers - (Benjamin Canou, review by Damien Doligez) - GPR#191: Making gc.h and some part of memory.h public (Thomas Refis) - GPR#196: Make [Thread.id] and [Thread.self] [noalloc] @@ -328,7 +376,7 @@ Features wishes: - GPR#165, GPR#221: fix windows compilation warnings (Bernhard Schommer, Gabriel Scherer, report by Alain Frisch) - GPR#189: Added .dylib and .so as extensions for ocamlmklib - (Edgar Aroutiounian, Peter Zotov) + (Edgar Aroutiounian, whitequark) - GPR#237: a CONTRIBUTING document (François Bobot, Gabriel Scherer, review by Xavier Leroy) - GPR#245: remove a few remaining French comments @@ -376,10 +424,10 @@ Compilers: incrementally (Jacques Garrigue) - PR#6642: replace $CAMLORIGIN in -ccopt with the path to cma or cmxa - (Peter Zotov, Gabriel Scherer, review by Damien Doligez) + (whitequark, Gabriel Scherer, review by Damien Doligez) - PR#6797: new option -output-complete-obj to output an object file with included runtime and autolink libraries - (Peter Zotov) + (whitequark) - PR#6845: -no-check-prims to tell ocamlc not to check primitives in runtime (Alain Frisch) - GPR#149: Attach documentation comments to parse tree @@ -395,18 +443,18 @@ OCamlbuild: - PR#6237: explicit "infer" tag to control or disable menhir --infer (Hugo Heuzard) - PR#6625: pass -linkpkg to files built with -output-obj. - (Peter Zotov) + (whitequark) - PR#6702: explicit "linkpkg" and "dontlink(foo)" flags - (Peter Zotov, Gabriel Scherer) + (whitequark, Gabriel Scherer) - PR#6712: Ignore common VCS directories - (Peter Zotov) + (whitequark) - PR#6720: pass -g to C compilers when tag 'debug' is set - (Peter Zotov, Gabriel Scherer) + (whitequark, Gabriel Scherer) - PR#6733: add .byte.so and .native.so targets to pass -output-obj -cclib -shared. - (Peter Zotov) + (whitequark) - PR#6733: "runtime_variant(X)" to pass -runtime-variant X option. - (Peter Zotov) + (whitequark) - PR#6774: new menhir-specific flags "only_tokens" and "external_tokens(Foo)" (François Pottier) @@ -428,7 +476,7 @@ Build system: - PR#5418 (comments) : generate dependencies with $(CC) instead of gcc (Damien Doligez and Michael Grünewald) - PR#6266: Cross compilation for iOs, Android etc - (Peter Zotov, review by Damien Doligez and Mark Shinwell) + (whitequark, review by Damien Doligez and Mark Shinwell) Installation procedure: - Update instructions for x86-64 PIC mode and POWER architecture builds @@ -445,7 +493,7 @@ Bug fixes: (Gabriel Scherer, request by the Coq team) - PR#5887: move the byterun/*.h headers to byterun/caml/*.h to avoid header name clashes - (Jérôme Vouillon and Adrien Nader and Peter Zotov) + (Jérôme Vouillon and Adrien Nader and whitequark) - PR#6281: Graphics window does not acknowledge second click (double click) (Kyle Headley) - PR#6490: incorrect backtraces in gdb on AArch64. Also fixes incorrect @@ -458,9 +506,9 @@ Bug fixes: - PR#6607: The manual doesn't mention 0x200 flag for OCAMLRUNPARAM=v (Alain Frisch) - PR#6616: allow meaningful use of -use-runtime without -custom. - (Peter Zotov) + (whitequark) - PR#6617: allow android build with pthreads support (since SDK r10c) - (Peter Zotov) + (whitequark) - PR#6626: ocamlbuild on cygwin cannot find ocamlfind (Gergely Szilvasy) - PR#6628: Configure script rejects legitimate arguments @@ -490,9 +538,9 @@ Bug fixes: type variable in place of a local abstract type (Jacques Garrigue, report by Mikhail Mandrykin) - PR#6693 (part two): Incorrect relocation types in x86-64 runtime system - (Peter Zotov, review by Jacques-Henri Jourdan, Xavier Leroy and Mark Shinwell) + (whitequark, review by Jacques-Henri Jourdan, Xavier Leroy and Mark Shinwell) - PR#6717: Pprintast does not print let-pattern attributes - (Gabriel Scherer, report by Peter Zotov) + (Gabriel Scherer, report by whitequark) - PR#6727: Printf.sprintf "%F" misbehavior (Benoît Vaugon, report by Vassili Karpov) - PR#6747: ocamlobjinfo: missing symbol caml_plugin_header due to underscore @@ -515,12 +563,12 @@ Bug fixes: - PR#6775: Digest.file leaks file descriptor on error (Valentin Gatien-Baron) - PR#6779: Cross-compilers cannot link bytecode using custom primitives - (Damien Doligez, request by Peter Zotov) + (Damien Doligez, request by whitequark) - PR#6787: Soundness bug with polymorphic variants (Jacques Garrigue, with help from Leo White and Grégoire Henry, report by Michael O'Connor) - PR#6790: otherlibs should be built with -g - (Damien Doligez, report by Peter Zotov) + (Damien Doligez, report by whitequark) - PR#6791: "%s@[", "%s@{" regression in Scanf (Benoît Vaugon) - PR#6793: ocamlbuild passes nonsensical "-ocamlc ..." commands to menhir @@ -583,9 +631,9 @@ Feature wishes: - PR#6452, GPR#140: add internal suport for custom printing formats (Jérémie Dimino) - PR#6641: add -g, -ocamlcflags, -ocamloptflags options to ocamlmklib - (Peter Zotov) + (whitequark) - PR#6693: also build libasmrun_shared.so and lib{asm,caml}run_pic.a - (Peter Zotov, review by Mark Shinwell) + (whitequark, review by Mark Shinwell) - PR#6842: export Typemod.modtype_of_package (Jacques Garrigue, request by Jun Furuse) - GPR#139: more versatile specification of locations of .annot @@ -611,7 +659,7 @@ Bug Fixes: - PR#6207: Configure doesn't detect features correctly on Haiku (Jessica Hamilton) - PR#6466: Non-exhaustive matching warning message for open types is confusing - (Peter Zotov) + (whitequark) - PR#6529: fix quadratic-time algorithm in Consistbl.extract. (Xavier Leroy, Alain Frisch, relase-worthy report by Jacques-Pascal Deplaix) - PR#6530: Add stack overflow handling for native code (OpenBSD i386 and amd64) @@ -625,7 +673,7 @@ Bug Fixes: - PR#6544: Bytes and CamlinternalFormat missing from threads stdlib.cma (Christopher Zimmermann) - PR#6546: -dsource omits parens for `List ((`String "A")::[]) in patterns - (Gabriel Scherer, report by Peter Zotov) + (Gabriel Scherer, report by whitequark) - PR#6547: __MODULE__ aborts the compiler if the module name cannot be inferred (Jacques Garrigue, report by Kaustuv Chaudhuri) - PR#6549: Debug section is sometimes not readable when using -pack @@ -1005,15 +1053,15 @@ Features wishes: - PR#6358: obey DESTDIR in install targets (Gabriel Scherer, request by François Berenger) - PR#6388, PR#6424: more parsetree correctness checks for -ppx users - (Alain Frisch, request by Peter Zotov and Jun Furuse) + (Alain Frisch, request by whitequark and Jun Furuse) - PR#6406: Expose OCaml version in C headers - (Peter Zotov and Romain Calascibetta) + (whitequark and Romain Calascibetta) - PR#6446: improve "unused declaration" warnings wrt. name shadowing (Alain Frisch) - PR#6495: ocamlbuild tags 'safe_string', 'unsafe_string' (Anil Madhavapeddy) - PR#6497: pass context information to -ppx preprocessors - (Peter Zotov, Alain Frisch) + (whitequark, Alain Frisch) - ocamllex: user-definable refill action (Frédéric Bour, review by Gabriel Scherer and Luc Maranget) - shorten syntax for functor signatures: "functor (M1:S1) (M2:S2) .. -> .." diff --git a/Makefile.shared b/Makefile.shared index 5b4dd17bb1..6a45e22541 100755 --- a/Makefile.shared +++ b/Makefile.shared @@ -17,8 +17,8 @@ CAMLRUN ?= boot/ocamlrun CAMLYACC ?= boot/ocamlyacc
include stdlib/StdlibModules
-CAMLC=$(CAMLRUN) boot/ocamlc -nostdlib -I boot
-CAMLOPT=$(CAMLRUN) ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink
+CAMLC=$(CAMLRUN) boot/ocamlc -g -nostdlib -I boot
+CAMLOPT=$(CAMLRUN) ./ocamlopt -g -nostdlib -I stdlib -I otherlibs/dynlink
COMPFLAGS=-strict-sequence -w +33..39+48+50 -warn-error A -bin-annot \
-safe-string $(INCLUDES)
LINKFLAGS=
diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index 1e39a9490d..4c012009e7 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -421,12 +421,11 @@ let output_epilogue f = let float_constants = ref ([] : (int64 * int) list) let add_float_constant cst = - let repr = Int64.bits_of_float cst in try - List.assoc repr !float_constants + List.assoc cst !float_constants with Not_found -> let lbl = new_label() in - float_constants := (repr, lbl) :: !float_constants; + float_constants := (cst, lbl) :: !float_constants; lbl let emit_float_constant f lbl = @@ -470,7 +469,7 @@ let emit_instr fallthrough i = else I.mov (nat n) (res i 0) | Lop(Iconst_float f) -> - begin match Int64.bits_of_float f with + begin match f with | 0x0000_0000_0000_0000L -> (* +0.0 *) I.xorpd (res i 0) (res i 0) | _ -> diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index 440f4630c4..2c8ecabc96 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -285,13 +285,12 @@ let num_literals = ref 0 (* Label a floating-point literal *) let float_literal f = - let repr = Int64.bits_of_float f in try - List.assoc repr !float_literals + List.assoc f !float_literals with Not_found -> let lbl = new_label() in num_literals := !num_literals + 2; - float_literals := (repr, lbl) :: !float_literals; + float_literals := (f, lbl) :: !float_literals; lbl (* Label a GOTREL literal *) @@ -393,9 +392,8 @@ let emit_instr i = | Lop(Iconst_int n | Iconst_blockheader n) -> emit_intconst i.res.(0) (Nativeint.to_int32 n) | Lop(Iconst_float f) when !fpu = Soft -> - let bits = Int64.bits_of_float f in - let high_bits = Int64.to_int32 (Int64.shift_right_logical bits 32) - and low_bits = Int64.to_int32 bits in + let high_bits = Int64.to_int32 (Int64.shift_right_logical f 32) + and low_bits = Int64.to_int32 f in if is_immediate low_bits || is_immediate high_bits then begin let ninstr_low = emit_intconst i.res.(0) low_bits and ninstr_high = emit_intconst i.res.(1) high_bits in @@ -427,7 +425,7 @@ let emit_instr i = let ex = ((ex + 3) land 0x07) lxor 0x04 in Some((sg lsl 7) lor (ex lsl 4) lor mn) end in - begin match encode (Int64.bits_of_float f) with + begin match encode f with None -> let lbl = float_literal f in ` fldd {emit_reg i.res.(0)}, {emit_label lbl}\n` diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp index bc0513940b..eec5915648 100644 --- a/asmcomp/arm64/emit.mlp +++ b/asmcomp/arm64/emit.mlp @@ -565,13 +565,12 @@ let emit_instr i = | Lop(Iconst_int n | Iconst_blockheader n) -> emit_intconst i.res.(0) n | Lop(Iconst_float f) -> - let b = Int64.bits_of_float f in - if b = 0L then + if f = 0L then ` fmov {emit_reg i.res.(0)}, xzr\n` - else if is_immediate_float b then - ` fmov {emit_reg i.res.(0)}, #{emit_printf "0x%Lx" b}\n` + else if is_immediate_float f then + ` fmov {emit_reg i.res.(0)}, #{emit_printf "0x%Lx" f}\n` else begin - let lbl = float_literal b in + let lbl = float_literal f in ` adrp {emit_reg reg_tmp1}, {emit_label lbl}\n`; ` ldr {emit_reg i.res.(0)}, [{emit_reg reg_tmp1}, #:lo12:{emit_label lbl}]\n` end diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index b81947215b..6ee617bbe0 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -119,7 +119,13 @@ let split_default_wrapper fun_id kind params body attr = let inner_id = Ident.create (Ident.name fun_id ^ "_inner") in let map_param p = try List.assoc p map with Not_found -> p in let args = List.map (fun p -> Lvar (map_param p)) params in - let wrapper_body = Lapply (Lvar inner_id, args, no_apply_info) in + let wrapper_body = + Lapply {ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=Lvar inner_id; + ap_args=args; + ap_inlined=Default_inline} + in let inner_params = List.map map_param params in let new_ids = List.map Ident.rename inner_params in @@ -859,7 +865,7 @@ let rec close fenv cenv = function (* We convert [f a] to [let a' = a in fun b c -> f a' b c] when fun_arity > nargs *) - | Lapply(funct, args, {apply_loc=loc; apply_inlined=attribute}) -> + | Lapply{ap_func = funct; ap_args = args; ap_loc = loc; ap_inlined = attribute} -> let nargs = List.length args in begin match (close fenv cenv funct, close_list fenv cenv args) with ((ufunct, Value_closure(fundesc, approx_res)), @@ -894,7 +900,11 @@ let rec close fenv cenv = function (Lfunction{ kind = Curried; params = final_args; - body = Lapply(funct, internal_args, mk_apply_info loc); + body = Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=funct; + ap_args=internal_args; + ap_inlined=Default_inline}; attr = default_function_attribute}) in let new_fun = iter first_args new_fun in @@ -964,7 +974,11 @@ let rec close fenv cenv = function end | Lprim(Pdirapply loc,[funct;arg]) | Lprim(Prevapply loc,[arg;funct]) -> - close fenv cenv (Lapply(funct, [arg], mk_apply_info loc)) + close fenv cenv (Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=funct; + ap_args=[arg]; + ap_inlined=Default_inline}) | Lprim(Pgetglobal id, []) as lam -> check_constant_result lam (getglobal id) diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index 70b4540d9a..abc5503339 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -439,13 +439,12 @@ let emit_floatspecial = function let float_constants = ref ([] : (int64 * int) list) let add_float_constant cst = - let repr = Int64.bits_of_float cst in try - List.assoc repr !float_constants + List.assoc cst !float_constants with Not_found -> let lbl = new_label() in - float_constants := (repr, lbl) :: !float_constants; + float_constants := (cst, lbl) :: !float_constants; lbl let emit_float64_split_directive x = @@ -502,7 +501,7 @@ let emit_instr fallthrough i = end else I.mov (nat n) (reg i.res.(0)) | Lop(Iconst_float f) -> - begin match Int64.bits_of_float f with + begin match f with | 0x0000_0000_0000_0000L -> (* +0.0 *) I.fldz () | 0x8000_0000_0000_0000L -> (* -0.0 *) diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index 3a7174763a..8a32f226f4 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -36,7 +36,7 @@ type operation = | Ispill | Ireload | Iconst_int of nativeint - | Iconst_float of float + | Iconst_float of int64 | Iconst_symbol of string | Iconst_blockheader of nativeint | Icall_ind diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index 618e5e4ce7..d86fc389ba 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -36,7 +36,7 @@ type operation = | Ispill | Ireload | Iconst_int of nativeint - | Iconst_float of float + | Iconst_float of int64 | Iconst_symbol of string | Iconst_blockheader of nativeint | Icall_ind diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index eac1231dca..320ad26ab7 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -550,11 +550,11 @@ let emit_instr i = begin match abi with | ELF32 -> let lbl = new_label() in - float_literals := (Int64.bits_of_float f, lbl) :: !float_literals; + float_literals := (f, lbl) :: !float_literals; ` addis 11, 0, {emit_upper emit_label lbl}\n`; ` lfd {emit_reg i.res.(0)}, {emit_lower emit_label lbl}(11)\n` | ELF64v1 | ELF64v2 -> - let entry = TocFloat (Int64.bits_of_float f) in + let entry = TocFloat f in let lbl = label_for_tocref entry in if !big_toc || !Clflags.for_package <> None then begin ` addis 11, 2, {emit_label lbl}@toc@ha\n`; diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index 7c4679f8de..7ddc62190a 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -109,7 +109,7 @@ let operation op arg ppf res = | Ireload -> fprintf ppf "%a (reload)" regs arg | Iconst_int n | Iconst_blockheader n -> fprintf ppf "%s" (Nativeint.to_string n) - | Iconst_float f -> fprintf ppf "%F" f + | Iconst_float f -> fprintf ppf "%F" (Int64.float_of_bits f) | Iconst_symbol s -> fprintf ppf "\"%s\"" s | Icall_ind -> fprintf ppf "call %a" regs arg | Icall_imm lbl -> fprintf ppf "call \"%s\" %a" lbl regs arg diff --git a/asmcomp/s390x/CSE.ml b/asmcomp/s390x/CSE.ml new file mode 100644 index 0000000000..735ec098c7 --- /dev/null +++ b/asmcomp/s390x/CSE.ml @@ -0,0 +1,39 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Bill O'Farrell, IBM *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2015 IBM (Bill O'Farrell with *) +(* help from Tristan Amini). All rights reserved. This file is *) +(* distributed under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* CSE for the Z Processor *) + +open Arch +open Mach +open CSEgen + +class cse = object (self) + +inherit cse_generic as super + +method! class_of_operation op = + match op with + | Ispecific(Imultaddf | Imultsubf) -> Op_pure + | _ -> super#class_of_operation op + +method! is_cheap_operation op = + match op with + | Iconst_int n | Iconst_blockheader n -> + n >= -0x8000_0000n && n <= 0x7FFF_FFFFn + | _ -> false + +end + +let fundecl f = + (new cse)#fundecl f diff --git a/asmcomp/s390x/arch.ml b/asmcomp/s390x/arch.ml new file mode 100644 index 0000000000..718062624a --- /dev/null +++ b/asmcomp/s390x/arch.ml @@ -0,0 +1,86 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Bill O'Farrell, IBM *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2015 IBM (Bill O'Farrell with *) +(* help from Tristan Amini). All rights reserved. This file is *) +(* distributed under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Specific operations for the Z processor *) + +open Format + +(* Machine-specific command-line options *) + +let pic_code = ref true + +let command_line_options = + [ "-fPIC", Arg.Set pic_code, + " Generate position-independent machine code (default)"; + "-fno-PIC", Arg.Clear pic_code, + " Generate position-dependent machine code" ] + +(* Specific operations *) + +type specific_operation = + Imultaddf (* multiply and add *) + | Imultsubf (* multiply and subtract *) + +(* Addressing modes *) + +type addressing_mode = + | Iindexed of int (* reg + displ *) + | Iindexed2 of int (* reg + reg + displ *) + +(* Sizes, endianness *) + +let big_endian = true + +let size_addr = 8 +let size_int = size_addr +let size_float = 8 + +let allow_unaligned_access = false + +(* Behavior of division *) + +let division_crashes_on_overflow = true + +(* Operations on addressing modes *) + +let identity_addressing = Iindexed 0 + +let offset_addressing addr delta = + match addr with + | Iindexed n -> Iindexed(n + delta) + | Iindexed2 n -> Iindexed2(n + delta) + +let num_args_addressing = function + | Iindexed n -> 1 + | Iindexed2 n -> 2 + +(* Printing operations and addressing modes *) + +let print_addressing printreg addr ppf arg = + match addr with + | Iindexed n -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a%s" printreg arg.(0) idx + | Iindexed2 n -> + let idx = if n <> 0 then Printf.sprintf " + %i" n else "" in + fprintf ppf "%a + %a%s" printreg arg.(0) printreg arg.(1) idx + +let print_specific_operation printreg op ppf arg = + match op with + | Imultaddf -> + fprintf ppf "%a *f %a +f %a" + printreg arg.(0) printreg arg.(1) printreg arg.(2) + | Imultsubf -> + fprintf ppf "%a *f %a -f %a" + printreg arg.(0) printreg arg.(1) printreg arg.(2) diff --git a/asmcomp/s390x/emit.mlp b/asmcomp/s390x/emit.mlp new file mode 100644 index 0000000000..bb1fb65fbf --- /dev/null +++ b/asmcomp/s390x/emit.mlp @@ -0,0 +1,767 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Emission of Linux on Z 64-bit assembly code *) + +module StringSet = + Set.Make(struct type t = string let compare (x:t) y = compare x y end) + +open Misc +open Cmm +open Arch +open Proc +open Reg +open Mach +open Linearize +open Emitaux + +(* Layout of the stack. The stack is kept 8-aligned. *) + +let stack_offset = ref 0 + +let frame_size () = + let size = + !stack_offset + (* Trap frame, outgoing parameters *) + size_int * num_stack_slots.(0) + (* Local int variables *) + size_float * num_stack_slots.(1) + (* Local float variables *) + (if !contains_calls then size_addr else 0) in (* The return address *) + Misc.align size 8 + +let slot_offset loc cls = + match loc with + Local n -> + if cls = 0 + then !stack_offset + num_stack_slots.(1) * size_float + n * size_int + else !stack_offset + n * size_float + | Incoming n -> frame_size() + n + | Outgoing n -> n + +(* Output a symbol *) + +let emit_symbol s = Emitaux.emit_symbol '.' s + +(* Output function call *) + +let emit_call s = + if !pic_code then + `brasl %r14, {emit_symbol s}@PLT` + else + `brasl %r14, {emit_symbol s}` + +(* Output a label *) + +let label_prefix = ".L" + +let emit_label lbl = + emit_string label_prefix; emit_int lbl + +let emit_data_label lbl = + emit_string label_prefix; emit_string "d"; emit_int lbl + +(* Section switching *) + +let data_space = " .section \".data\"\n" + +let code_space = " .section \".text\"\n" + +let rodata_space = " .section \".rodata\"\n" + +(* Output a pseudo-register *) + +let emit_reg r = + match r.loc with + | Reg r -> emit_string (register_name r) + | _ -> fatal_error "Emit.emit_reg" + + +let emit_gpr r = emit_string "%r"; emit_int r + +let emit_fpr r = emit_string "%f"; emit_int r + +(* Special registers *) + +let reg_f15 = phys_reg 115 + +(* Output a stack reference *) + +let emit_stack r = + match r.loc with + Stack s -> + let ofs = slot_offset s (register_class r) in `{emit_int ofs}(%r15)` + | _ -> fatal_error "Emit.emit_stack" + + +(* Output a load or store operation *) + +let emit_load_store instr addressing_mode addr n arg = + match addressing_mode with + | Iindexed ofs -> + ` {emit_string instr} {emit_reg arg}, {emit_int ofs}({emit_reg addr.(n)})\n` + | Iindexed2 ofs -> + ` {emit_string instr} {emit_reg arg}, {emit_int ofs}({emit_reg addr.(n)},{emit_reg addr.(n+1)})\n` + +(* Adjust the stack pointer down by N. + Choose the shortest instruction possible for the value of N. *) + +let emit_stack_adjust n = + let n = -n in + if n = 0 then () + else if n >= 0 && n < 4096 then + ` la %r15, {emit_int n}(%r15)\n` + else if n >= -0x80000 && n < 0x80000 then + ` lay %r15, {emit_int n}(%r15)\n` + else + ` agfi %r15, {emit_int n}\n` + +(* Emit a 'add immediate' *) + +let emit_addimm res arg n = + if n >= 0 && n < 4096 then + ` la {emit_reg res}, {emit_int n}({emit_reg arg})\n` + else if n >= -0x80000 && n < 0x80000 then + ` lay {emit_reg res}, {emit_int n}({emit_reg arg})\n` + else begin + if arg.loc <> res.loc then + ` lgr {emit_reg res}, {emit_reg arg}\n`; + ` agfi {emit_reg res}, {emit_int n}\n` + end + +(* After a comparison, extract the result as 0 or 1 *) +(* The locgr instruction is not available in the z10 architecture, + so this code is currently unused. *) +(* +let emit_set_comp cmp res = + ` lghi %r1, 1\n`; + ` lghi {emit_reg res}, 0\n`; + begin match cmp with + Ceq -> ` locgre {emit_reg res}, %r1\n` + | Cne -> ` locgrne {emit_reg res}, %r1\n` + | Cgt -> ` locgrh {emit_reg res}, %r1\n` + | Cle -> ` locgrnh {emit_reg res}, %r1\n` + | Clt -> ` locgrl {emit_reg res}, %r1\n` + | Cge -> ` locgrnl {emit_reg res}, %r1\n` + end +*) + +(* Record live pointers at call points *) + +let record_frame live dbg = + let lbl = new_label() in + let live_offset = ref [] in + Reg.Set.iter + (function + | {typ = Val; loc = Reg r} -> + live_offset := (r lsl 1) + 1 :: !live_offset + | {typ = Val; loc = Stack s} as reg -> + live_offset := slot_offset s (register_class reg) :: !live_offset + | {typ = Addr} as r -> + Misc.fatal_error ("bad GC root " ^ Reg.name r) + | _ -> ()) + live; + frame_descriptors := + { fd_lbl = lbl; + fd_frame_size = frame_size(); + fd_live_offset = !live_offset; + fd_debuginfo = dbg } :: !frame_descriptors; + lbl + +(* Record calls to caml_call_gc, emitted out of line. *) + +type gc_call = + { gc_lbl: label; (* Entry label *) + gc_return_lbl: label; (* Where to branch after GC *) + gc_frame_lbl: label } (* Label of frame descriptor *) + +let call_gc_sites = ref ([] : gc_call list) + +let emit_call_gc gc = + `{emit_label gc.gc_lbl}: {emit_call "caml_call_gc"}\n`; + `{emit_label gc.gc_frame_lbl}: brcl 15, {emit_label gc.gc_return_lbl}\n` + +(* Record calls to caml_ml_array_bound_error, emitted out of line. *) + +type bound_error_call = + { bd_lbl: label; (* Entry label *) + bd_frame: label } (* Label of frame descriptor *) + +let bound_error_sites = ref ([] : bound_error_call list) +let bound_error_call = ref 0 + +let bound_error_label dbg = + if !Clflags.debug then begin + let lbl_bound_error = new_label() in + let lbl_frame = record_frame Reg.Set.empty dbg in + bound_error_sites := + { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; + lbl_bound_error + end else begin + if !bound_error_call = 0 then bound_error_call := new_label(); + !bound_error_call + end + +let emit_call_bound_error bd = + `{emit_label bd.bd_lbl}: {emit_call "caml_ml_array_bound_error"}\n`; + `{emit_label bd.bd_frame}:\n` + +let emit_call_bound_errors () = + List.iter emit_call_bound_error !bound_error_sites; + if !bound_error_call > 0 then + `{emit_label !bound_error_call}: {emit_call "caml_ml_array_bound_error"}\n` + +(* Record floating-point and large integer literals *) + +let float_literals = ref ([] : (int64 * int) list) +let int_literals = ref ([] : (nativeint * int) list) + +(* Masks for conditional branches after comparisons *) + +let branch_for_comparison = function + Ceq -> 8 | Cne -> 7 + | Cle -> 12 | Cgt -> 2 + | Cge -> 10 | Clt -> 4 + +let name_for_int_comparison = function + Isigned cmp -> ("cgr", branch_for_comparison cmp) + | Iunsigned cmp -> ("clgr", branch_for_comparison cmp) + +let name_for_int_comparison_imm = function + Isigned cmp -> ("cgfi", branch_for_comparison cmp) + | Iunsigned cmp -> ("clgfi", branch_for_comparison cmp) + +(* bit 0 = eq, bit 1 = lt, bit 2 = gt, bit 3 = unordered*) +let branch_for_float_comparison cmp neg = + match cmp with + Ceq -> if neg then 7 else 8 + | Cne -> if neg then 8 else 7 + | Cle -> if neg then 3 else 12 + | Cgt -> if neg then 13 else 2 + | Cge -> if neg then 5 else 10 + | Clt -> if neg then 11 else 4 + +(* Names for various instructions *) + +let name_for_intop = function + Iadd -> "agr" + | Isub -> "sgr" + | Imul -> "msgr" + | Iand -> "ngr" + | Ior -> "ogr" + | Ixor -> "xgr" + | _ -> Misc.fatal_error "Emit.Intop" + +let name_for_floatop1 = function + Inegf -> "lcdbr" + | Iabsf -> "lpdbr" + | _ -> Misc.fatal_error "Emit.Iopf1" + +let name_for_floatop2 = function + Iaddf -> "adbr" + | Isubf -> "sdbr" + | Imulf -> "mdbr" + | Idivf -> "ddbr" + | _ -> Misc.fatal_error "Emit.Iopf2" + +let name_for_specific = function + Imultaddf -> "madbr" + | Imultsubf -> "msdbr" + +(* Name of current function *) +let function_name = ref "" +(* Entry point for tail recursive calls *) +let tailrec_entry_point = ref 0 + +(* Output the assembly code for an instruction *) + +let emit_instr i = + emit_debug_info i.dbg; + match i.desc with + Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + if src.loc <> dst.loc then begin + match (src, dst) with + {loc = Reg rs; typ = (Val | Int | Addr)}, {loc = Reg rd} -> + ` lgr {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> + ` ldr {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg rs; typ = (Val | Int | Addr)}, {loc = Stack sd} -> + ` stg {emit_reg src}, {emit_stack dst}\n` + | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> + ` std {emit_reg src}, {emit_stack dst}\n` + | {loc = Stack ss; typ = (Val | Int | Addr)}, {loc = Reg rd} -> + ` lg {emit_reg dst}, {emit_stack src}\n` + | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> + ` ldy {emit_reg dst}, {emit_stack src}\n` + | (_, _) -> + fatal_error "Emit: Imove" + end + | Lop(Iconst_int n | Iconst_blockheader n) -> + if n >= -0x8000n && n <= 0x7FFFn then begin + ` lghi {emit_reg i.res.(0)}, {emit_nativeint n}\n`; + end else if n >= -0x8000_0000n && n <= 0x7FFF_FFFFn then begin + ` lgfi {emit_reg i.res.(0)}, {emit_nativeint n}\n`; + end else begin + let lbl = new_label() in + int_literals := (n, lbl) :: !int_literals; + ` lgrl {emit_reg i.res.(0)}, {emit_label lbl}\n`; + end + | Lop(Iconst_float f) -> + let lbl = new_label() in + float_literals := (f, lbl) :: !float_literals; + ` larl %r1, {emit_label lbl}\n`; + ` ld {emit_reg i.res.(0)}, 0(%r1)\n` + | Lop(Iconst_symbol s) -> + if !pic_code then + ` lgrl {emit_reg i.res.(0)}, {emit_symbol s}@GOTENT\n` + else + ` larl {emit_reg i.res.(0)}, {emit_symbol s}\n`; + | Lop(Icall_ind) -> + ` basr %r14, {emit_reg i.arg.(0)}\n`; + let lbl = record_frame i.live i.dbg in + `{emit_label lbl}:\n` + + | Lop(Icall_imm s) -> + if !pic_code then + ` brasl %r14, {emit_symbol s}@PLT\n` + else + ` brasl %r14, {emit_symbol s}\n`; + let lbl = record_frame i.live i.dbg in + `{emit_label lbl}:\n`; + | Lop(Itailcall_ind) -> + let n = frame_size() in + if !contains_calls then + ` lg %r14, {emit_int(n - size_addr)}(%r15)\n`; + emit_stack_adjust (-n); + ` br {emit_reg i.arg.(0)}\n` + | Lop(Itailcall_imm s) -> + if s = !function_name then + ` brcl 15, {emit_label !tailrec_entry_point}\n` + else begin + let n = frame_size() in + if !contains_calls then + ` lg %r14, {emit_int(n - size_addr)}(%r15)\n`; + emit_stack_adjust (-n); + if !pic_code then + ` brcl 15, {emit_symbol s}@PLT\n` + else + ` brcl 15, {emit_symbol s}\n` + end + + | Lop(Iextcall(s, alloc)) -> + if alloc then begin + if !pic_code then begin + ` lgrl %r7, {emit_symbol s}@GOTENT\n`; + ` brasl %r14, {emit_symbol "caml_c_call"}@PLT\n` + end else begin + ` larl %r7, {emit_symbol s}\n`; + ` brasl %r14, {emit_symbol "caml_c_call"}\n` + end; + let lbl = record_frame i.live i.dbg in + `{emit_label lbl}:\n`; + end else begin + if !pic_code then + ` brasl %r14, {emit_symbol s}@PLT\n` + else + ` brasl %r14, {emit_symbol s}\n` + end + + | Lop(Istackoffset n) -> + emit_stack_adjust n; + stack_offset := !stack_offset + n + + | Lop(Iload(chunk, addr)) -> + let loadinstr = + match chunk with + Byte_unsigned -> "llgc" + | Byte_signed -> "lgb" + | Sixteen_unsigned -> "llgh" + | Sixteen_signed -> "lgh" + | Thirtytwo_unsigned -> "llgf" + | Thirtytwo_signed -> "lgf" + | Word_int | Word_val -> "lg" + | Single -> "ley" + | Double | Double_u -> "ldy" in + emit_load_store loadinstr addr i.arg 0 i.res.(0); + if chunk = Single then + ` ldebr {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` + + | Lop(Istore(Single, addr, _)) -> + ` ledbr %f15, {emit_reg i.arg.(0)}\n`; + emit_load_store "stey" addr i.arg 1 reg_f15 + | Lop(Istore(chunk, addr, _)) -> + let storeinstr = + match chunk with + Byte_unsigned | Byte_signed -> "stcy" + | Sixteen_unsigned | Sixteen_signed -> "sthy" + | Thirtytwo_unsigned | Thirtytwo_signed -> "sty" + | Word_int | Word_val -> "stg" + | Single -> assert false + | Double | Double_u -> "stdy" in + emit_load_store storeinstr addr i.arg 1 i.arg.(0) + + | Lop(Ialloc n) -> + let lbl_redo = new_label() in + let lbl_call_gc = new_label() in + let lbl_frame = record_frame i.live i.dbg in + call_gc_sites := + { gc_lbl = lbl_call_gc; + gc_return_lbl = lbl_redo; + gc_frame_lbl = lbl_frame } :: !call_gc_sites; + `{emit_label lbl_redo}:`; + ` lay %r11, {emit_int(-n)}(%r11)\n`; + ` clgr %r11, %r10\n`; + ` brcl 4, {emit_label lbl_call_gc}\n`; (* less than *) + ` la {emit_reg i.res.(0)}, 8(%r11)\n` + + | Lop(Iintop Imulh) -> + (* Hacker's Delight section 8.3: + mul-high-signed(a, b) = mul-high-unsigned(a, b) + - a if b < 0 + - b if a < 0 + or, without branches, + mul-high-signed(a, b) = mul-high-unsigned(a, b) + - (a & (b >>s 63)) + - (b & (a >>s 63)) + *) + ` lgr %r1, {emit_reg i.arg.(0)}\n`; + ` mlgr %r0, {emit_reg i.arg.(1)}\n`; + (* r0:r1 is 128-bit unsigned product; r0 is the high bits *) + ` srag %r1, {emit_reg i.arg.(0)}, 63\n`; + ` ngr %r1, {emit_reg i.arg.(1)}\n`; + ` sgr %r0, %r1\n`; + ` srag %r1, {emit_reg i.arg.(1)}, 63\n`; + ` ngr %r1, {emit_reg i.arg.(0)}\n`; + ` sgr %r0, %r1\n`; + ` lgr {emit_reg i.res.(0)}, %r0\n` + | Lop(Iintop Imod) -> + ` lgr %r1, {emit_reg i.arg.(0)}\n`; + ` dsgr %r0, {emit_reg i.arg.(1)}\n`; + ` lgr {emit_reg i.res.(0)}, %r0\n` + | Lop(Iintop Idiv) -> + ` lgr %r1, {emit_reg i.arg.(0)}\n`; + ` dsgr %r0, {emit_reg i.arg.(1)}\n`; + ` lgr {emit_reg i.res.(0)}, %r1\n` + | Lop(Iintop Ilsl) -> + ` sllg {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, 0({emit_reg i.arg.(1)})\n` + | Lop(Iintop Ilsr) -> + ` srlg {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, 0({emit_reg i.arg.(1)})\n` + | Lop(Iintop Iasr) -> + ` srag {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, 0({emit_reg i.arg.(1)})\n` + | Lop(Iintop(Icomp cmp)) -> + let lbl = new_label() in + let (comp, mask) = name_for_int_comparison cmp in + ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` lghi {emit_reg i.res.(0)}, 1\n`; + ` brc {emit_int mask}, {emit_label lbl}\n`; + ` lghi {emit_reg i.res.(0)}, 0\n`; + `{emit_label lbl}:\n` + | Lop(Iintop Icheckbound) -> + let lbl = bound_error_label i.dbg in + ` clgr {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` brcl 12, {emit_label lbl}\n` (* branch if unsigned le *) + | Lop(Iintop op) -> + assert (i.arg.(0).loc = i.res.(0).loc); + let instr = name_for_intop op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Iintop_imm(Iadd, n)) -> + emit_addimm i.res.(0) i.arg.(0) n + | Lop(Iintop_imm(Isub, n)) -> + emit_addimm i.res.(0) i.arg.(0) (-n) + | Lop(Iintop_imm(Icomp cmp, n)) -> + let lbl = new_label() in + let (comp, mask) = name_for_int_comparison_imm cmp in + ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_int n}\n`; + ` lghi {emit_reg i.res.(0)}, 1\n`; + ` brc {emit_int mask}, {emit_label lbl}\n`; + ` lghi {emit_reg i.res.(0)}, 0\n`; + `{emit_label lbl}:\n` + | Lop(Iintop_imm(Icheckbound, n)) -> + let lbl = bound_error_label i.dbg in + if n >= 0 then begin + ` clgfi {emit_reg i.arg.(0)}, {emit_int n}\n`; + ` brcl 12, {emit_label lbl}\n` (* branch if unsigned le *) + end else begin + ` brcl 15, {emit_label lbl}\n` (* branch always *) + end + | Lop(Iintop_imm(Ilsl, n)) -> + ` sllg {emit_reg i.res.(0)}, {emit_reg i.arg.(0)},{emit_int n}(%r0)\n` + | Lop(Iintop_imm(Ilsr, n)) -> + ` srlg {emit_reg i.res.(0)}, {emit_reg i.arg.(0)},{emit_int n}(%r0)\n` + | Lop(Iintop_imm(Iasr, n)) -> + ` srag {emit_reg i.res.(0)}, {emit_reg i.arg.(0)},{emit_int n}(%r0)\n` + | Lop(Iintop_imm(Iand, n)) -> + assert (i.arg.(0).loc = i.res.(0).loc); + ` nilf {emit_reg i.res.(0)}, {emit_int (n land 0xFFFF_FFFF)}\n` + | Lop(Iintop_imm(Ior, n)) -> + assert (i.arg.(0).loc = i.res.(0).loc); + ` oilf {emit_reg i.res.(0)}, {emit_int n}\n` + | Lop(Iintop_imm(Ixor, n)) -> + assert (i.arg.(0).loc = i.res.(0).loc); + ` xilf {emit_reg i.res.(0)}, {emit_int n}\n` + | Lop(Iintop_imm(Imul, n)) -> + assert (i.arg.(0).loc = i.res.(0).loc); + ` msgfi {emit_reg i.res.(0)}, {emit_int n}\n` + | Lop(Iintop_imm((Imulh | Idiv | Imod), _)) -> + assert false + | Lop(Inegf | Iabsf as op) -> + let instr = name_for_floatop1 op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` + | Lop(Iaddf | Isubf | Imulf | Idivf as op) -> + assert (i.arg.(0).loc = i.res.(0).loc); + let instr = name_for_floatop2 op in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n`; + | Lop(Ifloatofint) -> + ` cdgbr {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` + | Lop(Iintoffloat) -> + (* rounding method #5 = round toward 0 *) + ` cgdbr {emit_reg i.res.(0)}, 5, {emit_reg i.arg.(0)}\n` + | Lop(Ispecific sop) -> + assert (i.arg.(2).loc = i.res.(0).loc); + let instr = name_for_specific sop in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` + | Lreloadretaddr -> + let n = frame_size() in + ` lg %r14, {emit_int(n - size_addr)}(%r15)\n` + | Lreturn -> + let n = frame_size() in + emit_stack_adjust (-n); + ` br %r14\n` + | Llabel lbl -> + `{emit_label lbl}:\n` + | Lbranch lbl -> + ` brcl 15,{emit_label lbl}\n` + | Lcondbranch(tst, lbl) -> + begin match tst with + Itruetest -> + ` cgfi {emit_reg i.arg.(0)}, 0\n`; + ` brcl 7, {emit_label lbl}\n` + | Ifalsetest -> + ` cgfi {emit_reg i.arg.(0)}, 0\n`; + ` brcl 8, {emit_label lbl}\n` + | Iinttest cmp -> + let (comp, mask) = name_for_int_comparison cmp in + ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` brcl {emit_int mask}, {emit_label lbl}\n` + | Iinttest_imm(cmp, n) -> + let (comp, mask) = name_for_int_comparison_imm cmp in + ` {emit_string comp} {emit_reg i.arg.(0)}, {emit_int n}\n`; + ` brcl {emit_int mask}, {emit_label lbl}\n` + | Ifloattest(cmp, neg) -> + ` cdbr {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + let mask = branch_for_float_comparison cmp neg in + ` brcl {emit_int mask}, {emit_label lbl}\n` + | Ioddtest -> + ` tmll {emit_reg i.arg.(0)}, 1\n`; + ` brcl 1, {emit_label lbl}\n` + | Ieventest -> + ` tmll {emit_reg i.arg.(0)}, 1\n`; + ` brcl 8, {emit_label lbl}\n` + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> + ` cgfi {emit_reg i.arg.(0)}, 1\n`; + begin match lbl0 with + None -> () + | Some lbl -> ` brcl 4, {emit_label lbl}\n` + end; + begin match lbl1 with + None -> () + | Some lbl -> ` brcl 8, {emit_label lbl}\n` + end; + begin match lbl2 with + None -> () + | Some lbl -> ` brcl 2, {emit_label lbl}\n` + end + | Lswitch jumptbl -> + let lbl = new_label() in + ` larl %r0, {emit_label lbl}\n`; + ` sllg %r1, {emit_reg i.arg.(0)}, 2(%r0)\n`; + ` agr %r1, %r0\n`; + ` lgf %r1, 0(%r1)\n`; + ` agr %r1, %r0\n`; + ` br %r1\n`; + emit_string rodata_space; + ` .align 8\n`; + `{emit_label lbl}:`; + for i = 0 to Array.length jumptbl - 1 do + ` .long {emit_label jumptbl.(i)} - {emit_label lbl}\n` + done; + emit_string code_space + | Lsetuptrap lbl -> + ` brasl %r14, {emit_label lbl}\n`; + | Lpushtrap -> + stack_offset := !stack_offset + 16; + emit_stack_adjust 16; + ` stg %r14, 0(%r15)\n`; + ` stg %r13, {emit_int size_addr}(%r15)\n`; + ` lgr %r13, %r15\n` + | Lpoptrap -> + ` lg %r13, {emit_int size_addr}(%r15)\n`; + emit_stack_adjust (-16); + stack_offset := !stack_offset - 16 + | Lraise k -> + begin match !Clflags.debug, k with + | true, Lambda.Raise_regular -> + ` brasl %r14, {emit_symbol "caml_raise_exn"}\n`; + let lbl = record_frame Reg.Set.empty i.dbg in + `{emit_label lbl}:\n` + | true, Lambda.Raise_reraise -> + ` brasl %r14, {emit_symbol "caml_reraise_exn"}\n`; + let lbl = record_frame Reg.Set.empty i.dbg in + `{emit_label lbl}:\n` + | false, _ + | true, Lambda.Raise_notrace -> + ` lg %r1, 0(%r13)\n`; + ` lgr %r15, %r13\n`; + ` lg %r13, {emit_int size_addr}(%r15)\n`; + emit_stack_adjust (-16); + ` br %r1\n` + end + + +(* Emit a sequence of instructions *) + +let rec emit_all i = + match i with + {desc = Lend} -> () + | _ -> + emit_instr i; + emit_all i.next + +(* Emission of a function declaration *) + +let fundecl fundecl = + function_name := fundecl.fun_name; + tailrec_entry_point := new_label(); + stack_offset := 0; + call_gc_sites := []; + bound_error_sites := []; + bound_error_call := 0; + float_literals := []; + int_literals := []; + ` .globl {emit_symbol fundecl.fun_name}\n`; + emit_debug_info fundecl.fun_dbg; + ` .type {emit_symbol fundecl.fun_name}, @function\n`; + emit_string code_space; + ` .align 8\n`; + `{emit_symbol fundecl.fun_name}:\n`; + let n = frame_size() in + emit_stack_adjust n; + if !contains_calls then + ` stg %r14, {emit_int(n - size_addr)}(%r15)\n`; + `{emit_label !tailrec_entry_point}:\n`; + emit_all fundecl.fun_body; + (* Emit the glue code to call the GC *) + List.iter emit_call_gc !call_gc_sites; + (* Emit the glue code to handle bound errors *) + emit_call_bound_errors(); + (* Emit the numeric literals *) + if !float_literals <> [] || !int_literals <> [] then begin + emit_string rodata_space; + ` .align 8\n`; + List.iter + (fun (f, lbl) -> + `{emit_label lbl}:`; + emit_float64_directive ".quad" f) + !float_literals; + List.iter + (fun (n, lbl) -> + `{emit_label lbl}: .quad {emit_nativeint n}\n`) + !int_literals + end + +(* Emission of data *) + +let declare_global_data s = + ` .globl {emit_symbol s}\n`; + ` .type {emit_symbol s}, @object\n` + +let emit_item = function + Cglobal_symbol s -> + declare_global_data s + | Cdefine_symbol s -> + `{emit_symbol s}:\n`; + | Cdefine_label lbl -> + `{emit_data_label lbl}:\n` + | Cint8 n -> + ` .byte {emit_int n}\n` + | Cint16 n -> + ` .short {emit_int n}\n` + | Cint32 n -> + ` .long {emit_nativeint n}\n` + | Cint n -> + ` .quad {emit_nativeint n}\n` + | Csingle f -> + emit_float32_directive ".long" (Int32.bits_of_float f) + | Cdouble f -> + emit_float64_directive ".quad" (Int64.bits_of_float f) + | Csymbol_address s -> + ` .quad {emit_symbol s}\n` + | Clabel_address lbl -> + ` .quad {emit_data_label lbl}\n` + | Cstring s -> + emit_bytes_directive " .byte " s + | Cskip n -> + if n > 0 then ` .space {emit_int n}\n` + | Calign n -> + if n < 8 then ` .align 8\n` + else ` .align {emit_int n}\n` + +let data l = + emit_string data_space; + ` .align 8\n`; + List.iter emit_item l + +(* Beginning / end of an assembly file *) + +let begin_assembly() = + reset_debug_info(); + (* Emit the beginning of the segments *) + let lbl_begin = Compilenv.make_symbol (Some "data_begin") in + emit_string data_space; + ` .align 8\n`; + declare_global_data lbl_begin; + `{emit_symbol lbl_begin}:\n`; + let lbl_begin = Compilenv.make_symbol (Some "code_begin") in + emit_string code_space; + declare_global_data lbl_begin; + `{emit_symbol lbl_begin}:\n` + +let end_assembly() = + (* Emit the end of the segments *) + emit_string code_space; + let lbl_end = Compilenv.make_symbol (Some "code_end") in + declare_global_data lbl_end; + `{emit_symbol lbl_end}:\n`; + ` .long 0\n`; + emit_string data_space; + ` .align 8\n`; + let lbl_end = Compilenv.make_symbol (Some "data_end") in + declare_global_data lbl_end; + `{emit_symbol lbl_end}:\n`; + ` .quad 0\n`; + (* Emit the frame descriptors *) + emit_string rodata_space; + ` .align 8\n`; + let lbl = Compilenv.make_symbol (Some "frametable") in + declare_global_data lbl; + `{emit_symbol lbl}:\n`; + emit_frames + { efa_label = (fun l -> ` .quad {emit_label l}\n`); + efa_16 = (fun n -> ` .short {emit_int n}\n`); + efa_32 = (fun n -> ` .long {emit_int32 n}\n`); + efa_word = (fun n -> ` .quad {emit_int n}\n`); + efa_align = (fun n -> ` .align {emit_int n}\n`); + efa_label_rel = (fun lbl ofs -> + ` .long ({emit_label lbl} - .) + {emit_int32 ofs}\n`); + efa_def_label = (fun l -> `{emit_label l}:\n`); + efa_string = (fun s -> emit_bytes_directive " .byte " (s ^ "\000")) + } diff --git a/asmcomp/s390x/proc.ml b/asmcomp/s390x/proc.ml new file mode 100644 index 0000000000..5f1e44bb2c --- /dev/null +++ b/asmcomp/s390x/proc.ml @@ -0,0 +1,208 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Bill O'Farrell, IBM *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2015 IBM (Bill O'Farrell with *) +(* help from Tristan Amini). All rights reserved. This file is *) +(* distributed under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Description of the Z Processor *) + +open Misc +open Cmm +open Reg +open Arch +open Mach + +(* Instruction selection *) + +let word_addressed = false + +(* Registers available for register allocation *) + +(* Integer register map: + 0 temporary, null register for some operations (volatile) + 1 temporary (volatile) + 2 - 5 function arguments and results (volatile) + 6 function arguments and results (persevered by C) + 7 - 9 general purpose, preserved by C + 10 allocation limit (preserved by C) + 11 allocation pointer (preserved by C) + 12 general purpose (preserved by C) + 13 trap pointer (preserved by C) + 14 return address (volatile) + 15 stack pointer (preserved by C) + Floating-point register map: + 0, 2, 4, 6 function arguments and results (volatile) + 1, 3, 5, 7 general purpose (volatile) + 8 - 14 general purpose, preserved by C + 15 temporary, preserved by C + +Note: integer register r12 is used as GOT pointer by some C compilers. +The code generated by OCaml does not need a GOT pointer, using PC-relative +addressing instead for accessing the GOT. This frees r12 as a +general-purpose register. *) + +let int_reg_name = + [| "%r2"; "%r3"; "%r4"; "%r5"; "%r6"; "%r7"; "%r8"; "%r9"; "%r12" |] + +let float_reg_name = + [| "%f0"; "%f2"; "%f4"; "%f6"; "%f1"; "%f3"; "%f5"; "%f7"; + "%f8"; "%f9"; "%f10"; "%f11"; "%f12"; "%f13"; "%f14"; "%f15" |] + +let num_register_classes = 2 + +let register_class r = + match r.typ with + | Val | Int | Addr -> 0 + | Float -> 1 + +let num_available_registers = [| 9; 15 |] + +let first_available_register = [| 0; 100 |] + +let register_name r = + if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) + +let rotate_registers = true + +(* Representation of hard registers by pseudo-registers *) + +let hard_int_reg = + let v = Array.make 9 Reg.dummy in + for i = 0 to 8 do v.(i) <- Reg.at_location Int (Reg i) done; v + +let hard_float_reg = + let v = Array.make 16 Reg.dummy in + for i = 0 to 15 do v.(i) <- Reg.at_location Float (Reg(100 + i)) done; v + +let all_phys_regs = + Array.append hard_int_reg hard_float_reg + +let phys_reg n = + if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) + +let stack_slot slot ty = + Reg.at_location ty (Stack slot) + +(* Calling conventions *) + +let calling_conventions + first_int last_int first_float last_float make_stack stack_ofs 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 + 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 + | 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 + done; + (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 loc_arguments arg = + calling_conventions 0 4 100 103 outgoing 0 arg +let loc_parameters arg = + let (loc, ofs) = calling_conventions 0 4 100 103 incoming 0 arg in loc +let loc_results res = + let (loc, ofs) = calling_conventions 0 4 100 103 not_supported 0 res in loc + +(* C calling conventions under SVR4: + use GPR 2-6 and FPR 0,2,4,6 just like ML calling conventions. + Using a float register does not affect the int registers. + 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 + (Array.map (fun reg -> [|reg|]) loc, ofs) + +let extcall_use_push = false + +(* Results are in GPR 2 and FPR 0 *) + +let loc_external_results res = + let (loc, ofs) = calling_conventions 0 0 100 100 not_supported 0 res in loc + +(* Exceptions are in GPR 2 *) + +let loc_exn_bucket = phys_reg 0 + +(* Volatile registers: none *) + +let regs_are_volatile rs = false + +(* Registers destroyed by operations *) + +let destroyed_at_c_call = + Array.of_list(List.map phys_reg + [0; 1; 2; 3; 4; + 100; 101; 102; 103; 104; 105; 106; 107]) + +let destroyed_at_oper = function + Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs + | Iop(Iextcall(_, false)) -> destroyed_at_c_call + | _ -> [||] + +let destroyed_at_raise = all_phys_regs + +(* Maximal register pressure *) + +let safe_register_pressure = function + Iextcall(_, _) -> 4 + | _ -> 9 + +let max_register_pressure = function + Iextcall(_, _) -> [| 4; 7 |] + | _ -> [| 9; 15 |] + +(* Pure operations (without any side effect besides updating their result + registers). *) + +let op_is_pure = function + | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> false + | Ispecific(Imultaddf | Imultsubf) -> true + | _ -> true + +(* Layout of the stack *) + +let num_stack_slots = [| 0; 0 |] +let contains_calls = ref false + +(* Calling the assembler *) + +let assemble_file infile outfile = + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) + +let init () = () diff --git a/asmcomp/s390x/reload.ml b/asmcomp/s390x/reload.ml new file mode 100644 index 0000000000..60ac59d26c --- /dev/null +++ b/asmcomp/s390x/reload.ml @@ -0,0 +1,47 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Reloading for the Z Processor *) + +open Arch +open Mach + +class reload = object (self) + +inherit Reloadgen.reload_generic as super + +(* For 2-address instructions, reloading must make sure that the + temporary result register is the same as the appropriate + argument register. *) + +method! reload_operation op arg res = + match op with + (* Two-address binary operations: arg.(0) and res.(0) must be the same *) + | Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) | Iaddf|Isubf|Imulf|Idivf -> + let res = self#makereg res.(0) in + ([|res; self#makereg arg.(1)|], [|res|]) + (* Three-address ternary operations: arg.(2) and res.(0) must be the same *) + | Ispecific(Imultaddf|Imultsubf) -> + let res = self#makereg res.(0) in + ([|self#makereg arg.(0); self#makereg arg.(1); res|], [|res|]) + (* One-address unary operations: arg.(0) and res.(0) must be the same *) + | Iintop_imm((Imul|Iand|Ior|Ixor), _) -> + let res = self#makereg res.(0) in + ([|res|], [|res|]) + (* Other instructions are regular *) + | _ -> + super#reload_operation op arg res + +end + +let fundecl f = + (new reload)#fundecl f diff --git a/asmcomp/s390x/scheduling.ml b/asmcomp/s390x/scheduling.ml new file mode 100644 index 0000000000..46da314778 --- /dev/null +++ b/asmcomp/s390x/scheduling.ml @@ -0,0 +1,60 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Bill O'Farrell, IBM *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2015 IBM (Bill O'Farrell with *) +(* help from Tristan Amini). All rights reserved. This file is *) +(* distributed under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Instruction scheduling for the Z processor *) + +open Arch +open Mach + +(* The z10 processor is in-order, dual-issue. It could benefit from some + basic-block scheduling, although precise latency information + is not available. + The z196 and later are out-of-order processors. Basic-block + scheduling probably makes no difference. *) + +class scheduler = object + +inherit Schedgen.scheduler_generic + +(* Latencies (in cycles). Wild guesses. We multiply all latencies by 2 + to favor dual-issue. *) + +method oper_latency = function + Ireload -> 4 + | Iload(_, _) -> 4 + | Iconst_float _ -> 4 (* turned into a load *) + | Iintop(Imul) -> 10 + | Iintop_imm(Imul, _) -> 10 + | Iaddf | Isubf | Imulf -> 8 + | Idivf -> 40 + | Ispecific(Imultaddf | Imultsubf) -> 8 + | _ -> 2 + +method reload_retaddr_latency = 4 + +(* Issue cycles. Rough approximations. *) + +method oper_issue_cycles = function + | Ialloc _ -> 4 + | Iintop(Imulh) -> 15 + | Iintop(Idiv|Imod) -> 20 + | Iintop(Icomp _) -> 4 + | Iintop_imm(Icomp _, _) -> 4 + | _ -> 1 + +method reload_retaddr_issue_cycles = 1 + +end + +let fundecl f = (new scheduler)#schedule_fundecl f diff --git a/asmcomp/s390x/selection.ml b/asmcomp/s390x/selection.ml new file mode 100644 index 0000000000..8417f7d6cc --- /dev/null +++ b/asmcomp/s390x/selection.ml @@ -0,0 +1,114 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Bill O'Farrell, IBM *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2015 IBM (Bill O'Farrell with *) +(* help from Tristan Amini). All rights reserved. This file is *) +(* distributed under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* Instruction selection for the Z processor *) + +open Cmm +open Arch +open Mach + +(* Recognition of addressing modes *) + +exception Use_default + +type addressing_expr = + | Alinear of expression + | Aadd of expression * expression + +let rec select_addr = function + | Cop((Caddi | Cadda | Caddv), [arg; Cconst_int m]) -> + let (a, n) = select_addr arg in (a, n + m) + | Cop((Caddi | Cadda | Caddv), [Cconst_int m; arg]) -> + let (a, n) = select_addr arg in (a, n + m) + | Cop((Caddi | Cadda | Caddv), [arg1; arg2]) -> + begin match (select_addr arg1, select_addr arg2) with + ((Alinear e1, n1), (Alinear e2, n2)) -> + (Aadd(e1, e2), n1 + n2) + | _ -> + (Aadd(arg1, arg2), 0) + end + | exp -> + (Alinear exp, 0) + +(* Instruction selection *) + +let pseudoregs_for_operation op arg res = + match op with + (* Two-address binary operations: arg.(0) and res.(0) must be the same *) + | Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) | Iaddf|Isubf|Imulf|Idivf -> + ([|res.(0); arg.(1)|], res) + | Ispecific(sop) -> + ( [| arg.(0); arg.(1); res.(0) |], [| res.(0) |]) + (* One-address unary operations: arg.(0) and res.(0) must be the same *) + | Iintop_imm((Imul|Iand|Ior|Ixor), _) -> (res, res) + (* Other instructions are regular *) + | _ -> raise Use_default + +class selector = object (self) + +inherit Selectgen.selector_generic as super + +method is_immediate n = (n <= 2147483647) && (n >= -2147483648) + +method select_addressing chunk exp = + let (a, d) = select_addr exp in + (* 20-bit signed displacement *) + if d < 0x80000 && d >= -0x80000 then begin + match a with + | Alinear e -> (Iindexed d, e) + | Aadd(e1, e2) -> (Iindexed2 d, Ctuple [e1; e2]) + end else + (Iindexed 0, exp) + +method! select_operation op args = + match (op, args) with + (* Z does not support immediate operands for multiply high *) + (Cmulhi, _) -> (Iintop Imulh, args) + (* The and, or and xor instructions have a different range of immediate + operands than the other instructions *) + | (Cand, _) -> self#select_logical Iand (-0x1_0000_0000) (-1) args + | (Cor, _) -> self#select_logical Ior 0 0xFFFF_FFFF args + | (Cxor, _) -> self#select_logical Ixor 0 0xFFFF_FFFF args + (* Recognize mult-add and mult-sub instructions *) + | (Caddf, [Cop(Cmulf, [arg1; arg2]); arg3]) -> + (Ispecific Imultaddf, [arg1; arg2; arg3]) + | (Caddf, [arg3; Cop(Cmulf, [arg1; arg2])]) -> + (Ispecific Imultaddf, [arg1; arg2; arg3]) + | (Csubf, [Cop(Cmulf, [arg1; arg2]); arg3]) -> + (Ispecific Imultsubf, [arg1; arg2; arg3]) + | _ -> + super#select_operation op args + +method select_logical op lo hi = function + [arg; Cconst_int n] when n >= lo && n <= hi -> + (Iintop_imm(op, n), [arg]) + | [Cconst_int n; arg] when n >= lo && n <= hi -> + (Iintop_imm(op, n), [arg]) + | args -> + (Iintop op, args) + + +method! insert_op_debug op dbg rs rd = + try + let (rsrc, rdst) = pseudoregs_for_operation op rs rd in + self#insert_moves rs rsrc; + self#insert_debug (Iop op) dbg rsrc rdst; + self#insert_moves rdst rd; + rd + with Use_default -> + super#insert_op_debug op dbg rs rd + +end + +let fundecl f = (new selector)#emit_fundecl f diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index 79d95b4313..92c7b1a216 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -449,7 +449,7 @@ method emit_expr env exp = Some(self#insert_op (Iconst_blockheader n) [||] r) | Cconst_float n -> let r = self#regs_for typ_float in - Some(self#insert_op (Iconst_float n) [||] r) + Some(self#insert_op (Iconst_float (Int64.bits_of_float n)) [||] r) | Cconst_symbol n -> let r = self#regs_for typ_val in Some(self#insert_op (Iconst_symbol n) [||] r) diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp index b29278fdf2..0a87bf4b34 100644 --- a/asmcomp/sparc/emit.mlp +++ b/asmcomp/sparc/emit.mlp @@ -323,7 +323,7 @@ let rec emit_instr i dslot = (* On UltraSPARC, the fzero instruction could be used to set a floating point register pair to zero. *) let lbl = new_label() in - float_constants := (lbl, Int64.bits_of_float f) :: !float_constants; + float_constants := (lbl, f) :: !float_constants; ` sethi %hi({emit_label lbl}), %g1\n`; ` ldd [%g1 + %lo({emit_label lbl})], {emit_reg i.res.(0)}\n` | Lop(Iconst_symbol s) -> diff --git a/asmrun/s390x.S b/asmrun/s390x.S new file mode 100644 index 0000000000..2c0c37292f --- /dev/null +++ b/asmrun/s390x.S @@ -0,0 +1,353 @@ +/***********************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* Bill O'Farrell, IBM */ +/* */ +/* Copyright 2015 Institut National de Recherche en Informatique et */ +/* en Automatique. Copyright 2015 IBM (Bill O'Farrell with help from */ +/* Tristan Amini). All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ +#define Addrglobal(reg,glob) \ + larl reg, glob +#define Loadglobal(reg,glob) \ + lgrl reg, glob +#define Storeglobal(reg,glob) \ + stgrl reg, glob +#define Loadglobal32(reg,glob) \ + lgfrl reg, glob +#define Storeglobal32(reg,glob) \ + strl reg, glob + + + .section ".text" + +/* Invoke the garbage collector. */ + + .globl caml_system__code_begin +caml_system__code_begin: + + .globl caml_call_gc + .type caml_call_gc, @function +caml_call_gc: + /* Set up stack frame */ +#define FRAMESIZE (16*8 + 16*8) + lay %r15, -FRAMESIZE(%r15) + /* Record return address into OCaml code */ + Storeglobal(%r14, caml_last_return_address) + /* Record lowest stack address */ + lay %r0, FRAMESIZE(%r15) + Storeglobal(%r0, caml_bottom_of_stack) + /* Record pointer to register array */ + lay %r0, (8*16)(%r15) + Storeglobal(%r0, caml_gc_regs) + /* Save current allocation pointer for debugging purposes */ + Storeglobal(%r11, caml_young_ptr) + /* Save exception pointer (if e.g. a sighandler raises) */ + Storeglobal(%r13, caml_exception_pointer) + /* Save all registers used by the code generator */ + stmg %r2,%r9, (8*16)(%r15) + stg %r12, (8*16 + 8*8)(%r15) + std %f0, 0(%r15) + std %f1, 8(%r15) + std %f2, 16(%r15) + std %f3, 24(%r15) + std %f4, 32(%r15) + std %f5, 40(%r15) + std %f6, 48(%r15) + std %f7, 56(%r15) + std %f8, 64(%r15) + std %f9, 72(%r15) + std %f10, 80(%r15) + std %f11, 88(%r15) + std %f12, 96(%r15) + std %f13, 108(%r15) + std %f14, 112(%r15) + std %f15, 120(%r15) + /* Call the GC */ + lay %r15, -160(%r15) + stg %r15, 0(%r15) + brasl %r14, caml_garbage_collection@PLT + lay %r15, 160(%r15) + /* Reload new allocation pointer and allocation limit */ + Loadglobal(%r11, caml_young_ptr) + Loadglobal(%r10, caml_young_limit) + /* Restore all regs used by the code generator */ + lmg %r2,%r9, (8*16)(%r15) + lg %r12, (8*16 + 8*8)(%r15) + ld %f0, 0(%r15) + ld %f1, 8(%r15) + ld %f2, 16(%r15) + ld %f3, 24(%r15) + ld %f4, 32(%r15) + ld %f5, 40(%r15) + ld %f6, 48(%r15) + ld %f7, 56(%r15) + ld %f8, 64(%r15) + ld %f9, 72(%r15) + ld %f10, 80(%r15) + ld %f11, 88(%r15) + ld %f12, 96(%r15) + ld %f13, 108(%r15) + ld %f14, 112(%r15) + ld %f15, 120(%r15) + /* Return to caller */ + Loadglobal(%r1, caml_last_return_address) + /* Deallocate stack frame */ + lay %r15, FRAMESIZE(%r15) + /* Return */ + br %r1 + +/* Call a C function from OCaml */ + + .globl caml_c_call + .type caml_c_call, @function +caml_c_call: + Storeglobal(%r15, caml_bottom_of_stack) + /* Save return address */ + ldgr %f15, %r14 + /* Get ready to call C function (address in r7) */ + /* Record lowest stack address and return address */ + Storeglobal(%r14, caml_last_return_address) + /* Make the exception handler and alloc ptr available to the C code */ + Storeglobal(%r11, caml_young_ptr) + Storeglobal(%r13, caml_exception_pointer) + /* Call the function */ + basr %r14, %r7 + /* restore return address */ + lgdr %r14,%f15 + /* Reload allocation pointer and allocation limit*/ + Loadglobal(%r11, caml_young_ptr) + Loadglobal(%r10, caml_young_limit) + /* Say we are back into OCaml code */ + lgfi %r0, 0 + Storeglobal(%r0, caml_last_return_address) + + /* Return to caller */ + br %r14 + +/* Raise an exception from OCaml */ + .globl caml_raise_exn + .type caml_raise_exn, @function +caml_raise_exn: + Loadglobal32(%r0, caml_backtrace_active) + cgfi %r0, 0 + jne .L110 +.L111: + /* Pop trap frame */ + lg %r1, 0(%r13) + lgr %r15, %r13 + lg %r13, 8(13) + agfi %r15, 16 + /* Branch to handler */ + br %r1 +.L110: + lgfi %r0, 0 + Storeglobal32(%r0, caml_backtrace_pos) +.L114: + ldgr %f15, %r2 /* preserve exn bucket in callee-save reg */ + /* arg1: exception bucket, already in r3 */ + lgr %r3,%r14 /* arg2: PC of raise */ + lgr %r4, %r15 /* arg3: SP of raise */ + lgr %r5, %r13 /* arg4: SP of handler */ + agfi %r15, -160 /* reserve stack space for C call */ + brasl %r14, caml_stash_backtrace@PLT + agfi %r15, 160 + lgdr %r2,%f15 /* restore exn bucket */ + j .L111 /* raise the exn */ + + .globl caml_reraise_exn + .type caml_reraise_exn, @function +caml_reraise_exn: + Loadglobal32(%r0, caml_backtrace_active) + cgfi %r0, 0 + jne .L114 + /* Pop trap frame */ + lg %r1, 0(%r13) + lgr %r15, %r13 + lg %r13, 8(%r13) + agfi %r15, 16 + /* Branch to handler */ + br %r1; + +/* Raise an exception from C */ + + .globl caml_raise_exception + .type caml_raise_exception, @function +caml_raise_exception: + Loadglobal32(0, caml_backtrace_active) + cgfi %r0, 0 + jne .L112 +.L113: + /* Reload OCaml global registers */ + Loadglobal(%r15, caml_exception_pointer) + Loadglobal(%r11, caml_young_ptr) + Loadglobal(%r10, caml_young_limit) + /* Say we are back into OCaml code */ + lgfi %r0, 0 + Storeglobal(%r0, caml_last_return_address) + /* Pop trap frame */ + lg %r1, 0(%r15) + lg %r13, 8(%r15) + agfi %r15, 16 + /* Branch to handler */ + br %r1; +.L112: + ldgr %f15,%r2 /* preserve exn bucket in callee-save reg */ + /* arg1: exception bucket, already in r2 */ + Loadglobal(%r3, caml_last_return_address) /* arg2: PC of raise */ + Loadglobal(%r4, caml_bottom_of_stack) /* arg3: SP of raise */ + Loadglobal(%r5, caml_exception_pointer) /* arg4: SP of handler */ + /* reserve stack space for C call */ + lay %r15, -160(%r15) + brasl %r14, caml_stash_backtrace@PLT + lay %r15, 160(%r15) + lgdr %r2,%f15 /* restore exn bucket */ /* restore exn bucket */ + j .L113 /* raise the exn */ + +/* Start the OCaml program */ + + .globl caml_start_program + .type caml_start_program, @function +caml_start_program: + Addrglobal(%r0, caml_program) + +/* Code shared between caml_start_program and caml_callback */ +.L102: + /* Allocate stack frame */ + lay %r15, -144(%r15) + /* Save all callee-save registers + return address */ + /* GPR 6..14 at sp + 0 ... sp + 64 + FPR 10..15 at sp + 72 ... sp + 128 */ + stmg %r6,%r14, 0(%r15) + std %f8, 72(%r15) + std %f9, 80(%r15) + std %f10, 88(%r15) + std %f11, 96(%r15) + std %f12, 104(%r15) + std %f13, 112(%r15) + std %f14, 120(%r15) + std %f15, 128(%r15) + + /* Set up a callback link */ + lay %r15, -32(%r15) + Loadglobal(%r1, caml_bottom_of_stack) + stg %r1, 0(%r15) + Loadglobal(%r1, caml_last_return_address) + stg %r1, 8(%r15) + Loadglobal(%r1, caml_gc_regs) + stg %r1, 16(%r15) + /* Build an exception handler to catch exceptions escaping out of OCaml */ + brasl %r14, .L103 + j .L104 +.L103: + lay %r15, -16(%r15) + stg %r14, 0(%r15) + Loadglobal(%r1, caml_exception_pointer) + stg %r1, 8(%r15) + lgr %r13, %r15 + /* Reload allocation pointers */ + Loadglobal(%r11, caml_young_ptr) + Loadglobal(%r10, caml_young_limit) + /* Call the OCaml code */ + lgr %r1,%r0 + basr %r14, %r1 +.L105: + /* Pop the trap frame, restoring caml_exception_pointer */ + lg %r0, 8(%r15) + Storeglobal(%r0, caml_exception_pointer) + la %r15, 16(%r15) + /* Pop the callback link, restoring the global variables */ +.L106: + lg %r5, 0(%r15) + lg %r6, 8(%r15) + lg %r1, 16(%r15) + Storeglobal(%r5, caml_bottom_of_stack) + Storeglobal(%r6, caml_last_return_address) + Storeglobal(%r1, caml_gc_regs) + la %r15, 32(%r15) + + /* Update allocation pointer */ + Storeglobal(%r11, caml_young_ptr) + + /* Restore registers */ + lmg %r6,%r14, 0(%r15) + ld %f8, 72(%r15) + ld %f9, 80(%r15) + ld %f10, 88(%r15) + ld %f11, 96(%r15) + ld %f12, 104(%r15) + ld %f13, 112(%r15) + ld %f14, 120(%r15) + ld %f15, 128(%r15) + + /* Return */ + lay %r15, 144(%r15) + br %r14 + + /* The trap handler: */ +.L104: + /* Update caml_exception_pointer */ + Storeglobal(%r13, caml_exception_pointer) + /* Encode exception bucket as an exception result and return it */ + oill %r2, 2 + j .L106 + +/* Callback from C to OCaml */ + + .globl caml_callback_exn + .type caml_callback_exn, @function +caml_callback_exn: + /* Initial shuffling of arguments */ + lgr %r0, %r2 /* Closure */ + lgr %r2, %r3 /* Argument */ + lgr %r3, %r0 + lg %r0, 0(%r3) /* Code pointer */ + j .L102 + + .globl caml_callback2_exn + .type caml_callback2_exn, @function +caml_callback2_exn: + lgr %r0, %r2 /* Closure */ + lgr %r2, %r3 /* First argument */ + lgr %r3, %r4 /* Second argument */ + lgr %r4, %r0 + Addrglobal(%r0, caml_apply2) + j .L102 + + .globl caml_callback3_exn + .type caml_callback3_exn, @function +caml_callback3_exn: + lgr %r0, %r2 /* Closure */ + lgr %r2, %r3 /* First argument */ + lgr %r3, %r4 /* Second argument */ + lgr %r4, %r5 /* Third argument */ + lgr %r5, %r0 + Addrglobal(%r0, caml_apply3) + j .L102 + + .globl caml_ml_array_bound_error + .type caml_ml_array_bound_error, @function +caml_ml_array_bound_error: + lay %r15, -160(%r15) /* Reserve stack space for C call */ + larl %r7, caml_array_bound_error + j caml_c_call + .globl caml_system__code_end +caml_system__code_end: + +/* Frame table */ + + .section ".data" + .align 8 + .globl caml_system__frametable + .type caml_system__frametable, @object +caml_system__frametable: + .quad 1 /* one descriptor */ + .quad .L105 /* return address into callback */ + .short -1 /* negative size count => use callback link */ + .short 0 /* no roots here */ + .align 8 diff --git a/asmrun/signals_asm.c b/asmrun/signals_asm.c index f30273bd48..6c9439de5b 100644 --- a/asmrun/signals_asm.c +++ b/asmrun/signals_asm.c @@ -144,7 +144,7 @@ int caml_set_signal_action(int signo, int action) /* Machine- and OS-dependent handling of bound check trap */ -#if defined(TARGET_power) || (defined(TARGET_sparc) && defined(SYS_solaris)) +#if defined(TARGET_power) || defined(TARGET_s390x) || (defined(TARGET_sparc) && defined(SYS_solaris)) DECLARE_SIGNAL_HANDLER(trap_handler) { #if defined(SYS_solaris) @@ -267,6 +267,14 @@ void caml_init_signals(void) } #endif +#if defined(TARGET_s390x) + { struct sigaction act; + sigemptyset(&act.sa_mask); + SET_SIGACT(act, trap_handler); + sigaction(SIGFPE, &act, NULL); + } +#endif + /* Stack overflow handling */ #ifdef HAS_STACK_OVERFLOW_DETECTION { diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h index 627e3b727e..03cdb87a97 100644 --- a/asmrun/signals_osdep.h +++ b/asmrun/signals_osdep.h @@ -283,6 +283,23 @@ #define CONTEXT_YOUNG_LIMIT (context->regs->gpr[30]) #define CONTEXT_YOUNG_PTR (context->regs->gpr[31]) #define CONTEXT_SP (context->regs->gpr[1]) + +/****************** s390x, ELF (Linux) */ +#elif defined(TARGET_s390x) && defined(SYS_elf) + + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, struct sigcontext * context) + + #define SET_SIGACT(sigact,name) \ + sigact.sa_handler = (void (*)(int)) (name); \ + sigact.sa_flags = 0 + + typedef unsigned long context_reg; + #define CONTEXT_PC (context->sregs->regs.psw.addr) + #define CONTEXT_EXCEPTION_POINTER (context->sregs->regs.gprs[13]) + #define CONTEXT_YOUNG_LIMIT (context->sregs->regs.gprs[10]) + #define CONTEXT_YOUNG_PTR (context->sregs->regs.gprs[11]) + #define CONTEXT_SP (context->sregs->regs.gprs[15]) /****************** PowerPC, BSD */ diff --git a/asmrun/stack.h b/asmrun/stack.h index a4f47c7f9e..2aad2a7e0a 100644 --- a/asmrun/stack.h +++ b/asmrun/stack.h @@ -50,6 +50,12 @@ #define Mark_scanned(sp, retaddr) Saved_return_address(sp) = (retaddr) | 1 #endif +#ifdef TARGET_s390x +#define Saved_return_address(sp) *((intnat *)((sp) - SIZEOF_PTR)) +#define Trap_frame_size 16 +#define Callback_link(sp) ((struct caml_context *)((sp) + Trap_frame_size)) +#endif + #ifdef TARGET_arm #define Saved_return_address(sp) *((intnat *)((sp) - 4)) #define Callback_link(sp) ((struct caml_context *)((sp) + 8)) diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex ba32993f0b..736ca1203f 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex 4a47869bcc..643130a403 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 911786114f..2ad2e44082 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 384fea2fce..2cb07c2481 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -453,7 +453,7 @@ let rec comp_expr env exp sz cont = end | Lconst cst -> Kconst cst :: cont - | Lapply(func, args, info) -> + | Lapply{ap_func = func; ap_args = args} -> let nargs = List.length args in if is_tailcall cont then begin comp_args env args sz @@ -577,7 +577,11 @@ let rec comp_expr env exp sz cont = comp_expr env arg sz (add_const_unit cont) | Lprim(Pdirapply loc, [func;arg]) | Lprim(Prevapply loc, [arg;func]) -> - let exp = Lapply(func, [arg], mk_apply_info loc) in + let exp = Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=func; + ap_args=[arg]; + ap_inlined=Default_inline} in comp_expr env exp sz cont | Lprim(Pnot, [arg]) -> let newcont = @@ -820,7 +824,7 @@ let rec comp_expr env exp sz cont = | Lev_after ty -> let info = match lam with - Lapply(_, args, _) -> Event_return (List.length args) + Lapply{ap_args = args} -> Event_return (List.length args) | Lsend(_, _, _, args, _) -> Event_return (List.length args + 1) | _ -> Event_other in diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index 2ea3f689b7..b2fc4c9d83 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -82,11 +82,7 @@ let add_ccobjs origin l = (* First pass: determine which units are needed *) -module IdentSet = - Set.Make(struct - type t = Ident.t - let compare = compare - end) +module IdentSet = Lambda.IdentSet let missing_globals = ref IdentSet.empty diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index d4cc29a066..2fcbbf11a4 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -166,22 +166,6 @@ type inline_attribute = | Never_inline (* [@inline never] *) | Default_inline (* no [@inline] attribute *) -type apply_info = { - apply_loc : Location.t; - apply_should_be_tailcall : bool; (* true if [@tailcall] was specified *) - apply_inlined : inline_attribute; (* specified with [@inlined] attribute *) -} - -let mk_apply_info ?(tailcall=false) ?(inlined_attribute=Default_inline) loc = - {apply_loc=loc; - apply_should_be_tailcall=tailcall; - apply_inlined=inlined_attribute;} - -let no_apply_info = - {apply_loc=Location.none; - apply_should_be_tailcall=false; - apply_inlined=Default_inline;} - type function_kind = Curried | Tupled type let_kind = Strict | Alias | StrictOpt | Variable @@ -197,7 +181,7 @@ type function_attribute = { type lambda = Lvar of Ident.t | Lconst of structured_constant - | Lapply of lambda * lambda list * apply_info + | Lapply of lambda_apply | Lfunction of lfunction | Llet of let_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda @@ -222,6 +206,13 @@ and lfunction = body: lambda; attr: function_attribute; } (* specified with [@inline] attribute *) +and lambda_apply = + { ap_func : lambda; + ap_args : lambda list; + ap_loc : Location.t; + ap_should_be_tailcall : bool; + ap_inlined : inline_attribute } + and lambda_switch = { sw_numconsts: int; sw_consts: (int * lambda) list; @@ -275,8 +266,10 @@ let make_key e = (* Mutable constants are not shared *) raise Not_simple | Lconst _ -> e - | Lapply (e,es,info) -> - Lapply (tr_rec env e,tr_recs env es,{info with apply_loc=Location.none}) + | Lapply ap -> + Lapply {ap with ap_func = tr_rec env ap.ap_func; + ap_args = tr_recs env ap.ap_args; + ap_loc = Location.none} | Llet (Alias,x,ex,e) -> (* Ignore aliases -> substitute *) let ex = tr_rec env ex in tr_rec (Ident.add x ex env) e @@ -357,7 +350,7 @@ let iter_opt f = function let iter f = function Lvar _ | Lconst _ -> () - | Lapply(fn, args, _) -> + | Lapply{ap_func = fn; ap_args = args} -> f fn; List.iter f args | Lfunction{kind; params; body} -> f body @@ -504,9 +497,10 @@ let subst_lambda s lam = Lvar id as l -> begin try Ident.find_same id s with Not_found -> l end | Lconst sc as l -> l - | Lapply(fn, args, loc) -> Lapply(subst fn, List.map subst args, loc) + | Lapply ap -> + Lapply{ap with ap_func = subst ap.ap_func; ap_args = List.map subst ap.ap_args} | Lfunction{kind; params; body; attr} -> - Lfunction{kind; params; body = subst body; attr} + Lfunction{kind; params; body = subst body; attr} | Llet(str, id, arg, body) -> Llet(str, id, subst arg, subst body) | Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body) | Lprim(p, args) -> Lprim(p, List.map subst args) diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index e23e4da86d..b0aac033c0 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -166,24 +166,6 @@ type inline_attribute = | Never_inline (* [@inline never] *) | Default_inline (* no [@inline] attribute *) -type apply_info = { - apply_loc : Location.t; - apply_should_be_tailcall : bool; (* true if [@tailcall] was specified *) - apply_inlined : inline_attribute; (* specified with [@inlined] attribute *) -} - -val no_apply_info : apply_info -(** Default [apply_info]: no location, no tailcall *) - -val mk_apply_info : ?tailcall:bool -> ?inlined_attribute:inline_attribute -> - Location.t -> apply_info -(** Build apply_info - @param tailcall if true, the application should be in tail position; - default false - @param inlined_attribute specify wether the function should be inlined - or not -*) - type function_kind = Curried | Tupled type let_kind = Strict | Alias | StrictOpt | Variable @@ -208,7 +190,7 @@ type function_attribute = { type lambda = Lvar of Ident.t | Lconst of structured_constant - | Lapply of lambda * lambda list * apply_info + | Lapply of lambda_apply | Lfunction of lfunction | Llet of let_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda @@ -235,6 +217,13 @@ and lfunction = body: lambda; attr: function_attribute; } (* specified with [@inline] attribute *) +and lambda_apply = + { ap_func : lambda; + ap_args : lambda list; + ap_loc : Location.t; + ap_should_be_tailcall : bool; (* true if [@tailcall] was specified *) + ap_inlined : inline_attribute } (* specified with the [@inline] attribute *) + and lambda_switch = { sw_numconsts: int; (* Number of integer cases *) sw_consts: (int * lambda) list; (* Integer cases *) diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index edd6e53141..5094152b58 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -1517,7 +1517,11 @@ let inline_lazy_force_cond arg loc = (* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *) Lprim(Pintcomp Ceq, [Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))]), - Lapply(force_fun, [varg], mk_apply_info loc), + Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=force_fun; + ap_args=[varg]; + ap_inlined=Default_inline}, (* ... arg *) varg)))) @@ -1535,7 +1539,11 @@ let inline_lazy_force_switch arg loc = sw_blocks = [ (Obj.forward_tag, Lprim(Pfield 0, [varg])); (Obj.lazy_tag, - Lapply(force_fun, [varg], mk_apply_info loc)) ]; + Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=force_fun; + ap_args=[varg]; + ap_inlined=Default_inline}) ]; sw_failaction = Some varg } )))) let inline_lazy_force arg loc = @@ -2990,7 +2998,7 @@ let assign_pat opt nraise catch_ids loc pat lam = (* pattern idents will be bound in staticcatch (let body), so we refresh them here to guarantee binders uniqueness *) let pat_ids = pat_bound_idents pat in - let fresh_ids = List.map (fun (id, _) -> id, Ident.rename id) pat_ids in + let fresh_ids = List.map (fun id -> id, Ident.rename id) pat_ids in (fresh_ids, alpha_pat fresh_ids pat, lam) :: acc in @@ -3019,7 +3027,7 @@ let for_let loc param pat body = | _ -> let opt = ref false in let nraise = next_raise_count () in - let catch_ids = List.map fst (pat_bound_idents pat) in + let catch_ids = pat_bound_idents pat in let bind = map_return (assign_pat opt nraise catch_ids loc pat) param in if !opt then Lstaticcatch(bind, (nraise, catch_ids), body) else simple_for_let loc param pat body diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 4430426481..0580b43dfd 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -266,12 +266,12 @@ let rec lam ppf = function Ident.print ppf id | Lconst cst -> struct_const ppf cst - | Lapply(lfun, largs, info) -> + | Lapply ap -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(apply@ %a%a%a%a)@]" lam lfun lams largs - apply_tailcall_attribute info.apply_should_be_tailcall - apply_inlined_attribute info.apply_inlined + fprintf ppf "@[<2>(apply@ %a%a%a%a)@]" lam ap.ap_func lams ap.ap_args + apply_tailcall_attribute ap.ap_should_be_tailcall + apply_inlined_attribute ap.ap_inlined | Lfunction{kind; params; body; attr} -> let pr_params ppf params = match kind with diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index 54fe035f27..eaf689c8dd 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -24,8 +24,9 @@ let rec eliminate_ref id = function Lvar v as lam -> if Ident.same v id then raise Real_reference else lam | Lconst cst as lam -> lam - | Lapply(e1, el, info) -> - Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el, info) + | Lapply ap -> + Lapply{ap with ap_func = eliminate_ref id ap.ap_func; + ap_args = List.map (eliminate_ref id) ap.ap_args} | Lfunction{kind; params; body} as lam -> if IdentSet.mem id (free_variables lam) then raise Real_reference @@ -106,7 +107,7 @@ let simplify_exits lam = let rec count = function | (Lvar _| Lconst _) -> () - | Lapply(l1, ll, _) -> count l1; List.iter count ll + | Lapply ap -> count ap.ap_func; List.iter count ap.ap_args | Lfunction{kind; params; body = l} -> count l | Llet(str, v, l1, l2) -> count l2; count l1 @@ -193,9 +194,11 @@ let simplify_exits lam = let rec simplif = function | (Lvar _|Lconst _) as l -> l - | Lapply(l1, ll, info) -> Lapply(simplif l1, List.map simplif ll, info) + | Lapply ap -> + Lapply{ap with ap_func = simplif ap.ap_func; + ap_args = List.map simplif ap.ap_args} | Lfunction{kind; params; body = l; attr} -> - Lfunction{kind; params; body = simplif l; attr} + Lfunction{kind; params; body = simplif l; attr} | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2) | Lletrec(bindings, body) -> Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) @@ -203,16 +206,24 @@ let simplify_exits lam = let ll = List.map simplif ll in match p, ll with (* Simplify %revapply, for n-ary functions with n > 1 *) - | Prevapply loc, [x; Lapply(f, args, info)] - | Prevapply loc, [x; Levent (Lapply(f, args, info),_)] -> - Lapply(f, args@[x], {info with apply_loc=loc}) - | Prevapply loc, [x; f] -> Lapply(f, [x], mk_apply_info loc) + | Prevapply loc, [x; Lapply ap] + | Prevapply loc, [x; Levent (Lapply ap,_)] -> + Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc} + | Prevapply loc, [x; f] -> Lapply {ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=f; + ap_args=[x]; + ap_inlined=Default_inline} (* Simplify %apply, for n-ary functions with n > 1 *) - | Pdirapply loc, [Lapply(f, args, info); x] - | Pdirapply loc, [Levent (Lapply(f, args, info),_); x] -> - Lapply(f, args@[x], {info with apply_loc=loc}) - | Pdirapply loc, [f; x] -> Lapply(f, [x], mk_apply_info loc) + | Pdirapply loc, [Lapply ap; x] + | Pdirapply loc, [Levent (Lapply ap,_); x] -> + Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc} + | Pdirapply loc, [f; x] -> Lapply {ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=f; + ap_args=[x]; + ap_inlined=Default_inline} | _ -> Lprim(p, ll) end @@ -339,14 +350,13 @@ let simplify_lets lam = | Lconst cst -> () | Lvar v -> use_var bv v 1 - | Lapply(Lfunction{kind = Curried; params; body}, args, _) + | Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args} when optimize && List.length params = List.length args -> count bv (beta_reduce params body args) - | Lapply(Lfunction{kind = Tupled; params; body}, - [Lprim(Pmakeblock _, args)], _) + | Lapply{ap_func = Lfunction{kind = Tupled; params; body}; ap_args = [Lprim(Pmakeblock _, args)]} when optimize && List.length params = List.length args -> count bv (beta_reduce params body args) - | Lapply(l1, ll, _) -> + | Lapply{ap_func = l1; ap_args = ll} -> count bv l1; List.iter (count bv) ll | Lfunction{kind; params; body = l} -> count Tbl.empty l @@ -432,14 +442,13 @@ let simplify_lets lam = l end | Lconst cst as l -> l - | Lapply(Lfunction{kind = Curried; params; body}, args, _) + | Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args} when optimize && List.length params = List.length args -> simplif (beta_reduce params body args) - | Lapply(Lfunction{kind = Tupled; params; body}, - [Lprim(Pmakeblock _, args)], _) + | Lapply{ap_func = Lfunction{kind = Tupled; params; body}; ap_args = [Lprim(Pmakeblock _, args)]} when optimize && List.length params = List.length args -> simplif (beta_reduce params body args) - | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc) + | Lapply ap -> Lapply {ap with ap_func = simplif ap.ap_func; ap_args = List.map simplif ap.ap_args} | Lfunction{kind; params; body = l; attr} -> begin match simplif l with Lfunction{kind=Curried; params=params'; body; attr} @@ -526,15 +535,15 @@ let rec emit_tail_infos is_tail lambda = match lambda with | Lvar _ -> () | Lconst _ -> () - | Lapply (func, l, ({apply_loc=loc} as info)) -> - if info.apply_should_be_tailcall + | Lapply ap -> + if ap.ap_should_be_tailcall && not is_tail && Warnings.is_active Warnings.Expect_tailcall - then Location.prerr_warning loc Warnings.Expect_tailcall; - emit_tail_infos false func; - list_emit_tail_infos false l; + then Location.prerr_warning ap.ap_loc Warnings.Expect_tailcall; + emit_tail_infos false ap.ap_func; + list_emit_tail_infos false ap.ap_args; if !Clflags.annotations then - Stypes.record (Stypes.An_call (loc, call_kind l)); + Stypes.record (Stypes.An_call (ap.ap_loc, call_kind ap.ap_args)) | Lfunction {body = lam} -> emit_tail_infos true lam | Llet (_, _, lam, body) -> diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 2dfa6646ff..1ec03c42ac 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -31,14 +31,19 @@ let lfunction params body = | _ -> Lfunction {kind = Curried; params; body; attr = default_function_attribute} -let lapply func args loc = - match func with - Lapply(func', args', _) -> - Lapply(func', args' @ args, loc) +let lapply ap = + match ap.ap_func with + Lapply ap' -> + Lapply {ap with ap_func = ap'.ap_func; ap_args = ap'.ap_args @ ap.ap_args} | _ -> - Lapply(func, args, loc) + Lapply ap -let mkappl (func, args) = Lapply (func, args, no_apply_info);; +let mkappl (func, args) = + Lapply {ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=func; + ap_args=args; + ap_inlined=Default_inline};; let lsequence l1 l2 = if l2 = lambda_unit then l1 else Lsequence(l1, l2) @@ -442,7 +447,13 @@ let transl_class_rebind ids cl vf = try let obj_init = Ident.create "obj_init" and self = Ident.create "self" in - let obj_init0 = lapply (Lvar obj_init) [Lvar self] no_apply_info in + let obj_init0 = + lapply {ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=Lvar obj_init; + ap_args=[Lvar self]; + ap_inlined=Default_inline} + in let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in if not (Translcore.check_recursive_lambda ids obj_init') then raise(Error(cl.cl_loc, Illegal_class_expr)); @@ -504,12 +515,12 @@ let rec builtin_meths self env env2 body = match body with | Llet(_, s', Lvar s, body) when List.mem s self -> builtin_meths (s'::self) env env2 body - | Lapply(f, [arg], _) when const_path f -> + | Lapply{ap_func = f; ap_args = [arg]} when const_path f -> let s, args = conv arg in ("app_"^s, f :: args) - | Lapply(f, [arg; p], _) when const_path f && const_path p -> + | Lapply{ap_func = f; ap_args = [arg; p]} when const_path f && const_path p -> let s, args = conv arg in ("app_"^s^"_const", f :: args @ [p]) - | Lapply(f, [p; arg], _) when const_path f && const_path p -> + | Lapply{ap_func = f; ap_args = [p; arg]} when const_path f && const_path p -> let s, args = conv arg in ("app_const_"^s, f :: p :: args) | Lsend(Self, Lvar n, Lvar s, [arg], _) when List.mem s self -> diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 4c67e684a7..efbb8919d9 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -395,10 +395,22 @@ let specialize_primitive loc p env ty ~has_constant_constructor = (* Eta-expand a primitive *) -let transl_primitive loc p env ty = +let used_primitives = Hashtbl.create 7 +let add_used_primitive loc p env path = + match path with + Some (Path.Pdot _ as path) -> + let path = Env.normalize_path (Some loc) env path in + let unit = Path.head path in + if Ident.global unit && not (Hashtbl.mem used_primitives path) + then Hashtbl.add used_primitives path loc + | _ -> () + +let transl_primitive loc p env ty path = let prim = try specialize_primitive loc p env ty ~has_constant_constructor:false - with Not_found -> Pccall p + with Not_found -> + add_used_primitive loc p env path; + Pccall p in match prim with | Plazyforce -> @@ -425,7 +437,7 @@ let transl_primitive loc p env ty = attr = default_function_attribute; body = Lprim(prim, List.map (fun id -> Lvar id) params) } -let transl_primitive_application loc prim env ty args = +let transl_primitive_application loc prim env ty path args = let prim_name = prim.prim_name in try let has_constant_constructor = match args with @@ -439,6 +451,7 @@ let transl_primitive_application loc prim env ty args = with Not_found -> if String.length prim_name > 0 && prim_name.[0] = '%' then raise(Error(loc, Unknown_builtin_primitive prim_name)); + add_used_primitive loc prim env path; Pccall prim @@ -682,7 +695,7 @@ and transl_exp0 e = body = Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], e.exp_loc)} else - transl_primitive e.exp_loc p e.exp_env e.exp_type + transl_primitive e.exp_loc p e.exp_env e.exp_type (Some path) | Texp_ident(path, _, {val_kind = Val_anc _}) -> raise(Error(e.exp_loc, Free_super_var)) | Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) -> @@ -707,7 +720,7 @@ and transl_exp0 e = | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p}); exp_type = prim_type } as funct, oargs) when List.length oargs >= p.prim_arity - && List.for_all (fun (_, arg,_) -> arg <> None) oargs -> + && List.for_all (fun (_, arg) -> arg <> None) oargs -> let args, args' = cut p.prim_arity oargs in let wrap f = if args' = [] @@ -716,17 +729,17 @@ and transl_exp0 e = let should_be_tailcall, funct = Translattribute.get_tailcall_attribute funct in - let inlined_attribute, funct = + let inlined, funct = Translattribute.get_inlined_attribute funct in let e = { e with exp_desc = Texp_apply(funct, oargs) } in - event_after e (transl_apply ~should_be_tailcall ~inlined_attribute + event_after e (transl_apply ~should_be_tailcall ~inlined f args' e.exp_loc) in let wrap0 f = if args' = [] then f else wrap f in let args = - List.map (function _, Some x, _ -> x | _ -> assert false) args in + List.map (function _, Some x -> x | _ -> assert false) args in let argl = transl_list args in let public_send = p.prim_name = "%send" || not !Clflags.native_code && p.prim_name = "%sendcache"in @@ -740,7 +753,7 @@ and transl_exp0 e = | _ -> assert false else begin let prim = transl_primitive_application - e.exp_loc p e.exp_env prim_type args in + e.exp_loc p e.exp_env prim_type (Some path) args in match (prim, args) with (Praise k, [arg1]) -> let targ = List.hd argl in @@ -772,11 +785,11 @@ and transl_exp0 e = let should_be_tailcall, funct = Translattribute.get_tailcall_attribute funct in - let inlined_attribute, funct = + let inlined, funct = Translattribute.get_inlined_attribute funct in let e = { e with exp_desc = Texp_apply(funct, oargs) } in - event_after e (transl_apply ~should_be_tailcall ~inlined_attribute + event_after e (transl_apply ~should_be_tailcall ~inlined (transl_exp funct) oargs e.exp_loc) | Texp_match(arg, pat_expr_list, exn_pat_expr_list, partial) -> transl_match e arg pat_expr_list exn_pat_expr_list partial @@ -812,6 +825,8 @@ and transl_exp0 e = Lprim(Pmakeblock(0, Immutable), transl_path e.exp_env path :: ll) end + | Texp_extension_constructor (_, path) -> + transl_path e.exp_env path | Texp_variant(l, arg) -> let tag = Btype.hash_variant l in begin match arg with @@ -894,8 +909,11 @@ and transl_exp0 e = in event_after e lam | Texp_new (cl, {Location.loc=loc}, _) -> - Lapply(Lprim(Pfield 0, [transl_path ~loc e.exp_env cl]), - [lambda_unit], no_apply_info) + Lapply{ap_should_be_tailcall=false; + ap_loc=loc; + ap_func=Lprim(Pfield 0, [transl_path ~loc e.exp_env cl]); + ap_args=[lambda_unit]; + ap_inlined=Default_inline} | Texp_instvar(path_self, path, _) -> Lprim(Parrayrefu Paddrarray, [transl_normal_path path_self; transl_normal_path path]) @@ -904,8 +922,11 @@ and transl_exp0 e = | Texp_override(path_self, modifs) -> let cpy = Ident.create "copy" in Llet(Strict, cpy, - Lapply(Translobj.oo_prim "copy", [transl_normal_path path_self], - no_apply_info), + Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=Translobj.oo_prim "copy"; + ap_args=[transl_normal_path path_self]; + ap_inlined=Default_inline}, List.fold_right (fun (path, _, expr) rem -> Lsequence(transl_setinstvar (Lvar cpy) path expr, rem)) @@ -1026,18 +1047,21 @@ and transl_tupled_cases patl_expr_list = List.map (fun (patl, guard, expr) -> (patl, transl_guard guard expr)) patl_expr_list -and transl_apply ?(should_be_tailcall=false) ?inlined_attribute lam sargs loc = +and transl_apply ?(should_be_tailcall=false) ?(inlined = Default_inline) lam sargs loc = let lapply funct args = match funct with Lsend(k, lmet, lobj, largs, loc) -> Lsend(k, lmet, lobj, largs @ args, loc) | Levent(Lsend(k, lmet, lobj, largs, loc), _) -> Lsend(k, lmet, lobj, largs @ args, loc) - | Lapply(lexp, largs, info) -> - Lapply(lexp, largs @ args, {info with apply_loc=loc}) + | Lapply ap -> + Lapply {ap with ap_args = ap.ap_args @ args; ap_loc = loc} | lexp -> - Lapply(lexp, args, mk_apply_info ~tailcall:should_be_tailcall - ?inlined_attribute loc) + Lapply {ap_should_be_tailcall=should_be_tailcall; + ap_loc=loc; + ap_func=lexp; + ap_args=args; + ap_inlined=inlined} in let rec build_apply lam args = function (None, optional) :: l -> @@ -1051,7 +1075,7 @@ and transl_apply ?(should_be_tailcall=false) ?inlined_attribute lam sargs loc = Lvar id in let args, args' = - if List.for_all (fun (_,opt) -> opt = Optional) args then [], args + if List.for_all (fun (_,opt) -> opt) args then [], args else args, [] in let lam = if args = [] then lam else lapply lam (List.rev_map fst args) in @@ -1077,7 +1101,7 @@ and transl_apply ?(should_be_tailcall=false) ?inlined_attribute lam sargs loc = | [] -> lapply lam (List.rev_map fst args) in - build_apply lam [] (List.map (fun (l, x,o) -> may_map transl_exp x, o) sargs) + (build_apply lam [] (List.map (fun (l, x) -> may_map transl_exp x, Btype.is_optional l) sargs) : Lambda.lambda) and transl_function loc untuplify_fn repr partial cases = match cases with diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli index 38b076d752..bc6ac9189a 100644 --- a/bytecomp/translcore.mli +++ b/bytecomp/translcore.mli @@ -19,15 +19,17 @@ open Lambda val transl_exp: expression -> lambda val transl_apply: ?should_be_tailcall:bool - -> ?inlined_attribute:inline_attribute - -> lambda -> (arg_label * expression option * optional) list + -> ?inlined:inline_attribute + -> lambda -> (arg_label * expression option) list -> Location.t -> lambda val transl_let: rec_flag -> value_binding list -> lambda -> lambda val transl_primitive: Location.t -> Primitive.description -> Env.t - -> Types.type_expr -> lambda + -> Types.type_expr -> Path.t option -> lambda val check_recursive_lambda: Ident.t list -> lambda -> bool +val used_primitives: (Path.t, Location.t) Hashtbl.t + type error = Illegal_letrec_pat | Illegal_letrec_expr diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index de0392b399..2f97e69db2 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -93,11 +93,13 @@ let rec apply_coercion strict restr arg = attr = default_function_attribute; body = apply_coercion Strict cc_res - (Lapply(Lvar id, - [apply_coercion Alias cc_arg (Lvar param)], - no_apply_info))}) + (Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=Lvar id; + ap_args=[apply_coercion Alias cc_arg (Lvar param)]; + ap_inlined=Default_inline})}) | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } -> - transl_primitive pc_loc pc_desc pc_env pc_type + transl_primitive pc_loc pc_desc pc_env pc_type None | Tcoerce_alias (path, cc) -> name_lambda strict arg (fun id -> apply_coercion Alias cc (transl_normal_path path)) @@ -280,7 +282,11 @@ let eval_rec_bindings bindings cont = bind_inits rem | (id, Some(loc, shape), rhs) :: rem -> Llet(Strict, id, - Lapply(mod_prim "init_mod", [loc; shape], no_apply_info), + Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=mod_prim "init_mod"; + ap_args=[loc; shape]; + ap_inlined=Default_inline}, bind_inits rem) and bind_strict = function [] -> @@ -295,8 +301,11 @@ let eval_rec_bindings bindings cont = | (id, None, rhs) :: rem -> patch_forwards rem | (id, Some(loc, shape), rhs) :: rem -> - Lsequence(Lapply(mod_prim "update_mod", [shape; Lvar id; rhs], - no_apply_info), + Lsequence(Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=mod_prim "update_mod"; + ap_args=[shape; Lvar id; rhs]; + ap_inlined=Default_inline}, patch_forwards rem) in bind_inits bindings @@ -368,8 +377,11 @@ let rec transl_module cc rootpath mexp = | Tmod_apply(funct, arg, ccarg) -> oo_wrap mexp.mod_env true (apply_coercion Strict cc) - (Lapply(transl_module Tcoerce_none None funct, - [transl_module ccarg None arg], mk_apply_info mexp.mod_loc)) + (Lapply{ap_should_be_tailcall=false; + ap_loc=mexp.mod_loc; + ap_func=transl_module Tcoerce_none None funct; + ap_args=[transl_module ccarg None arg]; + ap_inlined=Default_inline}) | Tmod_constraint(arg, mty, _, ccarg) -> transl_module (compose_coercions cc ccarg) rootpath arg | Tmod_unpack(arg, _) -> @@ -400,7 +412,7 @@ and transl_structure fields cc rootpath = function match cc with Tcoerce_primitive p -> transl_primitive p.pc_loc - p.pc_desc p.pc_env p.pc_type + p.pc_desc p.pc_env p.pc_type None | _ -> apply_coercion Strict cc (get_field pos)) pos_cc_list)) and id_pos_list = @@ -479,15 +491,49 @@ and pure_module m = let _ = Translcore.transl_module := transl_module +let scan_used_globals lam = + let globals = ref IdentSet.empty in + let rec scan lam = + Lambda.iter scan lam; + match lam with + Lprim ((Pgetglobal id | Psetglobal id), _) -> + globals := IdentSet.add id !globals + | _ -> () + in + scan lam; !globals + +let wrap_globals body = + let globals = scan_used_globals body in + let add_global id req = + if IdentSet.mem id globals then req else IdentSet.add id req in + let required = + Hashtbl.fold (fun path loc -> add_global (Path.head path)) + used_primitives IdentSet.empty + in + let required = + List.fold_right add_global (Env.get_required_globals ()) required + in + Env.reset_required_globals (); + Hashtbl.clear used_primitives; + IdentSet.fold + (fun id expr -> Lsequence(Lprim(Pgetglobal id, []), expr)) + required body + (* Location.prerr_warning loc + (Warnings.Nonrequired_global (Ident.name (Path.head path), + "uses the primitive " ^ + Printtyp.string_of_path path))) *) + (* Compile an implementation *) let transl_implementation module_name (str, cc) = reset_labels (); primitive_declarations := []; + Hashtbl.clear used_primitives; let module_id = Ident.create_persistent module_name in - Lprim(Psetglobal module_id, - [transl_label_init - (transl_struct [] cc (global_path module_id) str)]) + let body = + transl_label_init + (transl_struct [] cc (global_path module_id) str) in + Lprim(Psetglobal module_id, [wrap_globals body]) (* Build the list of value identifiers defined by a toplevel structure @@ -708,7 +754,7 @@ let transl_store_structure glob map prims str = Lsequence(Lprim(Psetfield(pos, false), [Lprim(Pgetglobal glob, []); transl_primitive Location.none - prim.pc_desc prim.pc_env prim.pc_type]), + prim.pc_desc prim.pc_env prim.pc_type None]), cont) in List.fold_right store_primitive prims @@ -760,6 +806,7 @@ let build_ident_map restr idlist more_ids = let transl_store_gen module_name ({ str_items = str }, restr) topl = reset_labels (); primitive_declarations := []; + Hashtbl.clear used_primitives; let module_id = Ident.create_persistent module_name in let (map, prims, size) = build_ident_map restr (defined_idents str) (more_idents str) in @@ -777,9 +824,9 @@ let transl_store_phrases module_name str = let transl_store_implementation module_name (str, restr) = let s = !transl_store_subst in transl_store_subst := Ident.empty; - let r = transl_store_gen module_name (str, restr) false in + let (i, r) = transl_store_gen module_name (str, restr) false in transl_store_subst := s; - r + (i, wrap_globals r) (* Compile a toplevel phrase *) @@ -798,16 +845,18 @@ let toplevel_name id = with Not_found -> Ident.name id let toploop_getvalue id = - Lapply(Lprim(Pfield toploop_getvalue_pos, - [Lprim(Pgetglobal toploop_ident, [])]), - [Lconst(Const_base(Const_string (toplevel_name id, None)))], - no_apply_info) + Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=Lprim(Pfield toploop_getvalue_pos, [Lprim(Pgetglobal toploop_ident, [])]); + ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None)))]; + ap_inlined=Default_inline} let toploop_setvalue id lam = - Lapply(Lprim(Pfield toploop_setvalue_pos, - [Lprim(Pgetglobal toploop_ident, [])]), - [Lconst(Const_base(Const_string (toplevel_name id, None))); lam], - no_apply_info) + Lapply{ap_should_be_tailcall=false; + ap_loc=Location.none; + ap_func=Lprim(Pfield toploop_setvalue_pos, [Lprim(Pgetglobal toploop_ident, [])]); + ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None))); lam]; + ap_inlined=Default_inline} let toploop_setvalue_id id = toploop_setvalue id (Lvar id) @@ -878,6 +927,7 @@ let transl_toplevel_item_and_close itm = let transl_toplevel_definition str = reset_labels (); + Hashtbl.clear used_primitives; make_sequence transl_toplevel_item_and_close str.str_items (* Compile the initialization code for a packed library *) @@ -970,4 +1020,6 @@ let reset () = primitive_declarations := []; transl_store_subst := Ident.empty; toploop_ident.Ident.flags <- 0; - aliased_idents := Ident.empty + aliased_idents := Ident.empty; + Env.reset_required_globals (); + Hashtbl.clear used_primitives diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index 64daa3d956..3bd1939212 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -97,12 +97,12 @@ let transl_label_init expr = (fun c id expr -> Llet(Alias, id, Lconst c, expr)) consts expr in - let expr = + (*let expr = List.fold_right (fun id expr -> Lsequence(Lprim(Pgetglobal id, []), expr)) (Env.get_required_globals ()) expr in - Env.reset_required_globals (); + Env.reset_required_globals ();*) reset_labels (); expr diff --git a/byterun/array.c b/byterun/array.c index bb462a4e76..be8735ef2b 100644 --- a/byterun/array.c +++ b/byterun/array.c @@ -12,7 +12,6 @@ /***********************************************************************/ /* Operations on arrays */ - #include <string.h> #include "caml/alloc.h" #include "caml/fail.h" @@ -391,8 +390,17 @@ CAMLprim value caml_array_concat(value al) lengths = static_lengths; } else { arrays = caml_stat_alloc(n * sizeof(value)); - offsets = caml_stat_alloc(n * sizeof(intnat)); - lengths = caml_stat_alloc(n * sizeof(value)); + offsets = malloc(n * sizeof(intnat)); + if (offsets == NULL) { + caml_stat_free(arrays); + caml_raise_out_of_memory(); + } + lengths = malloc(n * sizeof(value)); + if (lengths == NULL) { + caml_stat_free(offsets); + caml_stat_free(arrays); + caml_raise_out_of_memory(); + } } /* Build the parameters to caml_array_gather */ for (i = 0, l = al; l != Val_int(0); l = Field(l, 1), i++) { diff --git a/byterun/caml/config.h b/byterun/caml/config.h index 63f0edd77c..490f38ac2e 100644 --- a/byterun/caml/config.h +++ b/byterun/caml/config.h @@ -70,6 +70,12 @@ typedef ARCH_INT32_TYPE int32_t; typedef ARCH_UINT32_TYPE uint32_t; typedef ARCH_INT64_TYPE int64_t; typedef ARCH_UINT64_TYPE uint64_t; +#if SIZEOF_SHORT == 2 +typedef short int16_t; +typedef unsigned short uint16_t; +#else +#error "No 16-bit integer type available" +#endif #endif #if SIZEOF_PTR == SIZEOF_LONG diff --git a/byterun/caml/hash.h b/byterun/caml/hash.h index d130068c48..279f39a310 100644 --- a/byterun/caml/hash.h +++ b/byterun/caml/hash.h @@ -30,7 +30,7 @@ CAMLextern uint32_t caml_hash_mix_float(uint32_t h, float d); CAMLextern uint32_t caml_hash_mix_string(uint32_t h, value s); #ifdef __cplusplus -extern "C" { +} #endif diff --git a/byterun/caml/intext.h b/byterun/caml/intext.h index 2c108a4ae0..b72d802ac0 100644 --- a/byterun/caml/intext.h +++ b/byterun/caml/intext.h @@ -27,7 +27,25 @@ /* Magic number */ -#define Intext_magic_number 0x8495A6BE +#define Intext_magic_number_small 0x8495A6BE +#define Intext_magic_number_big 0x8495A6BF + +/* Header format for the "small" model: 20 bytes + 0 "small" magic number + 4 length of marshaled data, in bytes + 8 number of shared blocks + 12 size in words when read on a 32-bit platform + 16 size in words when read on a 64-bit platform + The 4 numbers are 32 bits each, in big endian. + + Header format for the "big" model: 32 bytes + 0 "big" magic number + 4 four reserved bytes, currently set to 0 + 8 length of marshaled data, in bytes + 16 number of shared blocks + 24 size in words when read on a 64-bit platform + The 3 numbers are 64 bits each, in big endian. +*/ /* Codes for the compact format */ @@ -41,16 +59,20 @@ #define CODE_SHARED8 0x4 #define CODE_SHARED16 0x5 #define CODE_SHARED32 0x6 +#define CODE_SHARED64 0x14 #define CODE_BLOCK32 0x8 #define CODE_BLOCK64 0x13 #define CODE_STRING8 0x9 #define CODE_STRING32 0xA +#define CODE_STRING64 0x15 #define CODE_DOUBLE_BIG 0xB #define CODE_DOUBLE_LITTLE 0xC #define CODE_DOUBLE_ARRAY8_BIG 0xD #define CODE_DOUBLE_ARRAY8_LITTLE 0xE #define CODE_DOUBLE_ARRAY32_BIG 0xF #define CODE_DOUBLE_ARRAY32_LITTLE 0x7 +#define CODE_DOUBLE_ARRAY64_BIG 0x16 +#define CODE_DOUBLE_ARRAY64_LITTLE 0x17 #define CODE_CODEPOINTER 0x10 #define CODE_INFIXPOINTER 0x11 #define CODE_CUSTOM 0x12 @@ -59,10 +81,12 @@ #define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG #define CODE_DOUBLE_ARRAY8_NATIVE CODE_DOUBLE_ARRAY8_BIG #define CODE_DOUBLE_ARRAY32_NATIVE CODE_DOUBLE_ARRAY32_BIG +#define CODE_DOUBLE_ARRAY64_NATIVE CODE_DOUBLE_ARRAY64_BIG #else #define CODE_DOUBLE_NATIVE CODE_DOUBLE_LITTLE #define CODE_DOUBLE_ARRAY8_NATIVE CODE_DOUBLE_ARRAY8_LITTLE #define CODE_DOUBLE_ARRAY32_NATIVE CODE_DOUBLE_ARRAY32_LITTLE +#define CODE_DOUBLE_ARRAY64_NATIVE CODE_DOUBLE_ARRAY64_LITTLE #endif /* Size-ing data structures for extern. Chosen so that diff --git a/byterun/caml/memory.h b/byterun/caml/memory.h index 9c8657ad39..419c5356a7 100644 --- a/byterun/caml/memory.h +++ b/byterun/caml/memory.h @@ -34,6 +34,7 @@ extern "C" { CAMLextern value caml_alloc_shr (mlsize_t wosize, tag_t); +CAMLextern value caml_alloc_shr_no_raise (mlsize_t wosize, tag_t); CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t); CAMLextern void caml_alloc_dependent_memory (mlsize_t bsz); CAMLextern void caml_free_dependent_memory (mlsize_t bsz); diff --git a/byterun/extern.c b/byterun/extern.c index c27e462dcd..8bdaf30909 100644 --- a/byterun/extern.c +++ b/byterun/extern.c @@ -28,6 +28,10 @@ #include "caml/mlvalues.h" #include "caml/reverse.h" +#ifdef _MSC_VER +#define inline _inline +#endif + static uintnat obj_counter; /* Number of objects emitted so far */ static uintnat size_32; /* Size in words of 32-bit block for struct. */ static uintnat size_64; /* Size in words of 64-bit block for struct. */ @@ -302,26 +306,47 @@ static void extern_stack_overflow(void) caml_raise_out_of_memory(); } +/* Conversion to big-endian */ + +static inline void store16(char * dst, int n) +{ + dst[0] = n >> 8; dst[1] = n; +} + +static inline void store32(char * dst, intnat n) +{ + dst[0] = n >> 24; dst[1] = n >> 16; dst[2] = n >> 8; dst[3] = n; +} + +static inline void store64(char * dst, int64_t n) +{ + dst[0] = n >> 56; dst[1] = n >> 48; dst[2] = n >> 40; dst[3] = n >> 32; + dst[4] = n >> 24; dst[5] = n >> 16; dst[6] = n >> 8; dst[7] = n; +} + /* Write characters, integers, and blocks in the output buffer */ -#define Write(c) \ - if (extern_ptr >= extern_limit) grow_extern_output(1); \ - *extern_ptr++ = (c) +static inline void write(int c) +{ + if (extern_ptr >= extern_limit) grow_extern_output(1); + *extern_ptr++ = c; +} -static void writeblock(char *data, intnat len) +static void writeblock(char * data, intnat len) { if (extern_ptr + len > extern_limit) grow_extern_output(len); - memmove(extern_ptr, data, len); + memcpy(extern_ptr, data, len); extern_ptr += len; } +static inline void writeblock_float8(double * data, intnat ndoubles) +{ #if ARCH_FLOAT_ENDIANNESS == 0x01234567 || ARCH_FLOAT_ENDIANNESS == 0x76543210 -#define writeblock_float8(data,ndoubles) \ - writeblock((char *)(data), (ndoubles) * 8) + writeblock((char *) data, ndoubles * 8); #else -#define writeblock_float8(data,ndoubles) \ - caml_serialize_block_float_8((data), (ndoubles)) + caml_serialize_block_float_8(data, ndoubles); #endif +} static void writecode8(int code, intnat val) { @@ -335,39 +360,25 @@ static void writecode16(int code, intnat val) { if (extern_ptr + 3 > extern_limit) grow_extern_output(3); extern_ptr[0] = code; - extern_ptr[1] = val >> 8; - extern_ptr[2] = val; + store16(extern_ptr + 1, val); extern_ptr += 3; } -static void write32(intnat val) -{ - if (extern_ptr + 4 > extern_limit) grow_extern_output(4); - extern_ptr[0] = val >> 24; - extern_ptr[1] = val >> 16; - extern_ptr[2] = val >> 8; - extern_ptr[3] = val; - extern_ptr += 4; -} - static void writecode32(int code, intnat val) { if (extern_ptr + 5 > extern_limit) grow_extern_output(5); extern_ptr[0] = code; - extern_ptr[1] = val >> 24; - extern_ptr[2] = val >> 16; - extern_ptr[3] = val >> 8; - extern_ptr[4] = val; + store32(extern_ptr + 1, val); extern_ptr += 5; } #ifdef ARCH_SIXTYFOUR static void writecode64(int code, intnat val) { - int i; if (extern_ptr + 9 > extern_limit) grow_extern_output(9); - *extern_ptr ++ = code; - for (i = 64 - 8; i >= 0; i -= 8) *extern_ptr++ = val >> i; + extern_ptr[0] = code; + store64(extern_ptr + 1, val); + extern_ptr += 9; } #endif @@ -383,7 +394,7 @@ static void extern_rec(value v) if (Is_long(v)) { intnat n = Long_val(v); if (n >= 0 && n < 0x40) { - Write(PREFIX_SMALL_INT + n); + write(PREFIX_SMALL_INT + n); } else if (n >= -(1 << 7) && n < (1 << 7)) { writecode8(CODE_INT8, n); } else if (n >= -(1 << 15) && n < (1 << 15)) { @@ -419,7 +430,7 @@ static void extern_rec(value v) in the externed block, and they are automatically shared. */ if (sz == 0) { if (tag < 16) { - Write(PREFIX_SMALL_BLOCK + tag); + write(PREFIX_SMALL_BLOCK + tag); } else { writecode32(CODE_BLOCK32, hd); } @@ -432,6 +443,10 @@ static void extern_rec(value v) writecode8(CODE_SHARED8, d); } else if (d < 0x10000) { writecode16(CODE_SHARED16, d); +#ifdef ARCH_SIXTYFOUR + } else if (d >= (uintnat)1 << 32) { + writecode64(CODE_SHARED64, d); +#endif } else { writecode32(CODE_SHARED32, d); } @@ -443,7 +458,7 @@ static void extern_rec(value v) case String_tag: { mlsize_t len = caml_string_length(v); if (len < 0x20) { - Write(PREFIX_SMALL_STRING + len); + write(PREFIX_SMALL_STRING + len); } else if (len < 0x100) { writecode8(CODE_STRING8, len); } else { @@ -451,8 +466,13 @@ static void extern_rec(value v) if (len > 0xFFFFFB && (extern_flags & COMPAT_32)) extern_failwith("output_value: string cannot be read back on " "32-bit platform"); -#endif + if (len < (uintnat)1 << 32) + writecode32(CODE_STRING32, len); + else + writecode64(CODE_STRING64, len); +#else writecode32(CODE_STRING32, len); +#endif } writeblock(String_val(v), len); size_32 += 1 + (len + 4) / 4; @@ -463,7 +483,7 @@ static void extern_rec(value v) case Double_tag: { if (sizeof(double) != 8) extern_invalid_argument("output_value: non-standard floats"); - Write(CODE_DOUBLE_NATIVE); + write(CODE_DOUBLE_NATIVE); writeblock_float8((double *) v, 1); size_32 += 1 + 2; size_64 += 1 + 1; @@ -482,8 +502,13 @@ static void extern_rec(value v) if (nfloats > 0x1FFFFF && (extern_flags & COMPAT_32)) extern_failwith("output_value: float array cannot be read back on " "32-bit platform"); -#endif + if (nfloats < (uintnat) 1 << 32) + writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats); + else + writecode64(CODE_DOUBLE_ARRAY64_NATIVE, nfloats); +#else writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats); +#endif } writeblock_float8((double *) v, nfloats); size_32 += 1 + nfloats * 2; @@ -506,7 +531,7 @@ static void extern_rec(value v) = Custom_ops_val(v)->serialize; if (serialize == NULL) extern_invalid_argument("output_value: abstract value (Custom)"); - Write(CODE_CUSTOM); + write(CODE_CUSTOM); writeblock(ident, strlen(ident) + 1); Custom_ops_val(v)->serialize(v, &sz_32, &sz_64); size_32 += 2 + ((sz_32 + 3) >> 2); /* header + ops + data */ @@ -517,19 +542,19 @@ static void extern_rec(value v) default: { value field0; if (tag < 16 && sz < 8) { - Write(PREFIX_SMALL_BLOCK + tag + (sz << 4)); -#ifdef ARCH_SIXTYFOUR - } else if (hd >= ((uintnat)1 << 32)) { - /* Is this case useful? The overflow check in extern_value will fail.*/ - writecode64(CODE_BLOCK64, Whitehd_hd (hd)); -#endif + write(PREFIX_SMALL_BLOCK + tag + (sz << 4)); } else { #ifdef ARCH_SIXTYFOUR if (sz > 0x3FFFFF && (extern_flags & COMPAT_32)) extern_failwith("output_value: array cannot be read back on " "32-bit platform"); -#endif + if (hd < (uintnat)1 << 32) + writecode32(CODE_BLOCK32, Whitehd_hd (hd)); + else + writecode64(CODE_BLOCK64, Whitehd_hd (hd)); +#else writecode32(CODE_BLOCK32, Whitehd_hd (hd)); +#endif } size_32 += 1 + sz; size_64 += 1 + sz; @@ -571,7 +596,9 @@ static void extern_rec(value v) static int extern_flag_values[] = { NO_SHARING, CLOSURES, COMPAT_32 }; -static intnat extern_value(value v, value flags) +static intnat extern_value(value v, value flags, + /*out*/ char header[32], + /*out*/ int * header_len) { intnat res_len; /* Parse flag list */ @@ -581,53 +608,58 @@ static intnat extern_value(value v, value flags) obj_counter = 0; size_32 = 0; size_64 = 0; - /* Write magic number */ - write32(Intext_magic_number); - /* Set aside space for the sizes */ - extern_ptr += 4*4; /* Marshal the object */ extern_rec(v); /* Record end of output */ close_extern_output(); /* Undo the modifications done on externed blocks */ extern_replay_trail(); - /* Write the sizes */ + /* Write the header */ res_len = extern_output_length(); #ifdef ARCH_SIXTYFOUR if (res_len >= ((intnat)1 << 32) || size_32 >= ((intnat)1 << 32) || size_64 >= ((intnat)1 << 32)) { - /* The object is so big its size cannot be written in the header. - Besides, some of the array lengths or string lengths or shared offsets - it contains may have overflowed the 32 bits used to write them. */ - free_extern_output(); - caml_failwith("output_value: object too big"); + /* The object is too big for the small header format. + Fail if we are in compat32 mode, or use big header. */ + if (extern_flags & COMPAT_32) { + free_extern_output(); + caml_failwith("output_value: object too big to be read back on " + "32-bit platform"); + } + store32(header, Intext_magic_number_big); + store32(header + 4, 0); + store64(header + 8, res_len); + store64(header + 16, obj_counter); + store64(header + 24, size_64); + *header_len = 32; + return res_len; } #endif - if (extern_userprovided_output != NULL) - extern_ptr = extern_userprovided_output + 4; - else { - extern_ptr = extern_output_first->data + 4; - extern_limit = extern_output_first->data + SIZE_EXTERN_OUTPUT_BLOCK; - } - write32(res_len - 5*4); - write32(obj_counter); - write32(size_32); - write32(size_64); + /* Use the small header format */ + store32(header, Intext_magic_number_small); + store32(header + 4, res_len); + store32(header + 8, obj_counter); + store32(header + 12, size_32); + store32(header + 16, size_64); + *header_len = 20; return res_len; } void caml_output_val(struct channel *chan, value v, value flags) { + char header[32]; + int header_len; struct output_block * blk, * nextblk; if (! caml_channel_binary_mode(chan)) caml_failwith("output_value: not a binary channel"); init_extern_output(); - extern_value(v, flags); + extern_value(v, flags, header, &header_len); /* During [caml_really_putblock], concurrent [caml_output_val] operations can take place (via signal handlers or context switching in systhreads), and [extern_output_first] may change. So, save it in a local variable. */ blk = extern_output_first; + caml_really_putblock(chan, header, header_len); while (blk != NULL) { caml_really_putblock(chan, blk->data, blk->end - blk->data); nextblk = blk->next; @@ -649,20 +681,24 @@ CAMLprim value caml_output_value(value vchan, value v, value flags) CAMLprim value caml_output_value_to_string(value v, value flags) { - intnat len, ofs; + char header[32]; + int header_len; + intnat data_len, ofs; value res; struct output_block * blk, * nextblk; init_extern_output(); - len = extern_value(v, flags); + data_len = extern_value(v, flags, header, &header_len); /* PR#4030: it is prudent to save extern_output_first before allocating the result, as in caml_output_val */ blk = extern_output_first; - res = caml_alloc_string(len); + res = caml_alloc_string(header_len + data_len); ofs = 0; + memcpy(&Byte(res, ofs), header, header_len); + ofs += header_len; while (blk != NULL) { int n = blk->end - blk->data; - memmove(&Byte(res, ofs), blk->data, n); + memcpy(&Byte(res, ofs), blk->data, n); ofs += n; nextblk = blk->next; free(blk); @@ -671,50 +707,64 @@ CAMLprim value caml_output_value_to_string(value v, value flags) return res; } +CAMLexport intnat caml_output_value_to_block(value v, value flags, + char * buf, intnat len) +{ + char header[32]; + int header_len; + intnat data_len; + /* At this point we don't know the size of the header. + Guess that it is small, and fix up later if not. */ + extern_userprovided_output = buf + 20; + extern_ptr = extern_userprovided_output; + extern_limit = buf + len; + data_len = extern_value(v, flags, header, &header_len); + if (header_len != 20) { + /* Bad guess! Need to shift the output to make room for big header. + Make sure there is room. */ + if (header_len + data_len > len) + caml_failwith("Marshal.to_buffer: buffer overflow"); + memmove(buf + header_len, buf + 20, data_len); + } + memcpy(buf, header, header_len); + return header_len + data_len; +} + CAMLprim value caml_output_value_to_buffer(value buf, value ofs, value len, value v, value flags) { - intnat len_res; - extern_userprovided_output = &Byte(buf, Long_val(ofs)); - extern_ptr = extern_userprovided_output; - extern_limit = extern_userprovided_output + Long_val(len); - len_res = extern_value(v, flags); - return Val_long(len_res); + intnat l = + caml_output_value_to_block(v, flags, + &Byte(buf, Long_val(ofs)), Long_val(len)); + return Val_long(l); } CAMLexport void caml_output_value_to_malloc(value v, value flags, /*out*/ char ** buf, /*out*/ intnat * len) -{ - intnat len_res; +{ + char header[32]; + int header_len; + intnat data_len; char * res; struct output_block * blk; init_extern_output(); - len_res = extern_value(v, flags); - res = malloc(len_res); + data_len = extern_value(v, flags, header, &header_len); + res = malloc(header_len + data_len); if (res == NULL) extern_out_of_memory(); *buf = res; - *len = len_res; + *len = header_len + data_len; + memcpy(res, header, header_len); + res += header_len; for (blk = extern_output_first; blk != NULL; blk = blk->next) { int n = blk->end - blk->data; - memmove(res, blk->data, n); + memcpy(res, blk->data, n); res += n; } free_extern_output(); } -CAMLexport intnat caml_output_value_to_block(value v, value flags, - char * buf, intnat len) -{ - intnat len_res; - extern_userprovided_output = buf; - extern_ptr = extern_userprovided_output; - extern_limit = extern_userprovided_output + len; - len_res = extern_value(v, flags); - return len_res; -} - /* Functions for writing user-defined marshallers */ CAMLexport void caml_serialize_int_1(int i) @@ -727,24 +777,22 @@ CAMLexport void caml_serialize_int_1(int i) CAMLexport void caml_serialize_int_2(int i) { if (extern_ptr + 2 > extern_limit) grow_extern_output(2); - extern_ptr[0] = i >> 8; - extern_ptr[1] = i; + store16(extern_ptr, i); extern_ptr += 2; } CAMLexport void caml_serialize_int_4(int32_t i) { if (extern_ptr + 4 > extern_limit) grow_extern_output(4); - extern_ptr[0] = i >> 24; - extern_ptr[1] = i >> 16; - extern_ptr[2] = i >> 8; - extern_ptr[3] = i; + store32(extern_ptr, i); extern_ptr += 4; } CAMLexport void caml_serialize_int_8(int64_t i) { - caml_serialize_block_8(&i, 1); + if (extern_ptr + 8 > extern_limit) grow_extern_output(8); + store64(extern_ptr, i); + extern_ptr += 8; } CAMLexport void caml_serialize_float_4(float f) @@ -760,7 +808,7 @@ CAMLexport void caml_serialize_float_8(double f) CAMLexport void caml_serialize_block_1(void * data, intnat len) { if (extern_ptr + len > extern_limit) grow_extern_output(len); - memmove(extern_ptr, data, len); + memcpy(extern_ptr, data, len); extern_ptr += len; } @@ -776,7 +824,7 @@ CAMLexport void caml_serialize_block_2(void * data, intnat len) extern_ptr = q; } #else - memmove(extern_ptr, data, len * 2); + memcpy(extern_ptr, data, len * 2); extern_ptr += len * 2; #endif } @@ -793,7 +841,7 @@ CAMLexport void caml_serialize_block_4(void * data, intnat len) extern_ptr = q; } #else - memmove(extern_ptr, data, len * 4); + memcpy(extern_ptr, data, len * 4); extern_ptr += len * 4; #endif } @@ -810,7 +858,7 @@ CAMLexport void caml_serialize_block_8(void * data, intnat len) extern_ptr = q; } #else - memmove(extern_ptr, data, len * 8); + memcpy(extern_ptr, data, len * 8); extern_ptr += len * 8; #endif } @@ -819,7 +867,7 @@ CAMLexport void caml_serialize_block_float_8(void * data, intnat len) { if (extern_ptr + 8 * len > extern_limit) grow_extern_output(8 * len); #if ARCH_FLOAT_ENDIANNESS == 0x01234567 - memmove(extern_ptr, data, len * 8); + memcpy(extern_ptr, data, len * 8); extern_ptr += len * 8; #elif ARCH_FLOAT_ENDIANNESS == 0x76543210 { diff --git a/byterun/floats.c b/byterun/floats.c index 4fa575ef3b..a4fd5a0afb 100644 --- a/byterun/floats.c +++ b/byterun/floats.c @@ -17,6 +17,7 @@ #include <stdio.h> #include <stdlib.h> #include <string.h> +#include <limits.h> #include "caml/alloc.h" #include "caml/fail.h" @@ -97,46 +98,179 @@ CAMLprim value caml_format_float(value fmt, value arg) return res; } -#if 0 -/*CAMLprim*/ value caml_float_of_substring(value vs, value idx, value l) +CAMLprim value caml_hexstring_of_float(value arg, value vprec, value vstyle) { - char parse_buffer[64]; - char * buf, * src, * dst, * end; - mlsize_t len, lenvs; - double d; - intnat flen = Long_val(l); - intnat fidx = Long_val(idx); + union { uint64_t i; double d; } u; + int sign, exp; + uint64_t m; + char buffer[64]; + char * buf, * p; + intnat prec; + int d; + value res; - lenvs = caml_string_length(vs); - len = - fidx >= 0 && fidx < lenvs && flen > 0 && flen <= lenvs - fidx - ? flen : 0; - buf = len < sizeof(parse_buffer) ? parse_buffer : caml_stat_alloc(len + 1); - src = String_val(vs) + fidx; - dst = buf; - while (len--) { - char c = *src++; - if (c != '_') *dst++ = c; + /* Allocate output buffer */ + prec = Long_val(vprec); + /* 12 chars for sign, 0x, decimal point, exponent */ + buf = (prec + 12 <= 64 ? buffer : caml_stat_alloc(prec + 12)); + /* Extract sign, mantissa, and exponent */ + u.d = Double_val(arg); + sign = u.i >> 63; + exp = (u.i >> 52) & 0x7FF; + m = u.i & (((uint64_t) 1 << 52) - 1); + /* Put sign */ + p = buf; + if (sign) { + *p++ = '-'; + } else { + switch (Int_val(vstyle)) { + case '+': *p++ = '+'; break; + case ' ': *p++ = ' '; break; + } } - *dst = 0; - if (dst == buf) goto error; - d = strtod((const char *) buf, &end); - if (end != dst) goto error; - if (buf != parse_buffer) caml_stat_free(buf); - return caml_copy_double(d); - error: - if (buf != parse_buffer) caml_stat_free(buf); - caml_failwith("float_of_string"); + /* Treat special cases */ + if (exp == 0x7FF) { + char * txt; + if (m == 0) txt = "infinity"; else txt = "nan"; + memcpy(p, txt, strlen(txt)); + p[strlen(txt)] = 0; + res = caml_copy_string(buf); + } else { + /* Output "0x" prefix */ + *p++ = '0'; *p++ = 'x'; + /* Normalize exponent and mantissa */ + if (exp == 0) { + if (m != 0) exp = -1022; /* denormal */ + } else { + exp = exp - 1023; + m = m | ((uint64_t) 1 << 52); + } + /* If a precision is given, and is small, round mantissa accordingly */ + prec = Long_val(vprec); + if (prec >= 0 && prec < 13) { + int i = 52 - prec * 4; + uint64_t unit = (uint64_t) 1 << i; + uint64_t half = unit >> 1; + uint64_t mask = unit - 1; + uint64_t frac = m & mask; + m = m & ~mask; + /* Round to nearest, ties to even */ + if (frac > half || (frac == half && (m & unit) != 0)) { + m += unit; + } + } + /* Leading digit */ + d = m >> 52; + *p++ = (d < 10 ? d + '0' : d - 10 + 'a'); + m = (m << 4) & (((uint64_t) 1 << 56) - 1); + /* Fractional digits. If a precision is given, print that number of + digits. Otherwise, print as many digits as needed to represent + the mantissa exactly. */ + if (prec >= 0 ? prec > 0 : m != 0) { + *p++ = '.'; + while (prec >= 0 ? prec > 0 : m != 0) { + d = m >> 52; + *p++ = (d < 10 ? d + '0' : d - 10 + 'a'); + m = (m << 4) & (((uint64_t) 1 << 56) - 1); + prec--; + } + } + *p = 0; + /* Add exponent */ + res = caml_alloc_sprintf("%sp%+d", buf, exp); + } + if (buf != buffer) caml_stat_free(buf); + return res; +} + +static int caml_float_of_hex(const char * s, double * res) +{ + int64_t m = 0; /* the mantissa - top 60 bits at most */ + int n_bits = 0; /* total number of bits read */ + int m_bits = 0; /* number of bits in mantissa */ + int x_bits = 0; /* number of bits after mantissa */ + int dec_point = -1; /* bit count corresponding to decimal point */ + /* -1 if no decimal point seen */ + int exp = 0; /* exponent */ + char * p; /* for converting the exponent */ + double f; + + while (*s != 0) { + char c = *s++; + switch (c) { + case '_': + break; + case '.': + if (dec_point >= 0) return -1; /* multiple decimal points */ + dec_point = n_bits; + break; + case 'p': case 'P': { + long e; + if (*s == 0) return -1; /* nothing after exponent mark */ + e = strtol(s, &p, 10); + if (*p != 0) return -1; /* ill-formed exponent */ + if (e < INT_MIN || e > INT_MAX) return -1; /* unreasonable exponent */ + exp = e; + s = p; /* stop at next loop iteration */ + break; + } + default: { /* Nonzero digit */ + int d; + if (c >= '0' && c <= '9') d = c - '0'; + else if (c >= 'A' && c <= 'F') d = c - 'A' + 10; + else if (c >= 'a' && c <= 'f') d = c - 'a' + 10; + else return -1; /* bad digit */ + n_bits += 4; + if (d == 0 && m == 0) break; /* leading zeros are skipped */ + if (m_bits < 60) { + /* There is still room in m. Add this digit to the mantissa. */ + m = (m << 4) + d; + m_bits += 4; + } else { + /* We've already collected 60 significant bits in m. + Now all we care about is whether there is a nonzero bit + after. In this case, round m to odd so that the later + rounding of m to FP produces the correct result. */ + if (d != 0) m |= 1; /* round to odd */ + x_bits += 4; + } + break; + } + } + } + /* Convert mantissa to FP. We use a signed conversion because we can + (m has 60 bits at most) and because it is faster + on several architectures. */ + f = (double) (int64_t) m; + /* Adjust exponent to take decimal point and extra digits into account */ + if (dec_point >= 0) exp = exp + (dec_point - n_bits); + exp = exp + x_bits; + /* Apply exponent if needed */ + if (exp != 0) f = ldexp(f, exp); + /* Done! */ + *res = f; + return 0; } -#endif CAMLprim value caml_float_of_string(value vs) { char parse_buffer[64]; char * buf, * src, * dst, * end; mlsize_t len; + int sign; double d; + /* Check for hexadecimal FP constant */ + src = String_val(vs); + sign = 1; + if (*src == '-') { sign = -1; src++; } + else if (*src == '+') { src++; }; + if (src[0] == '0' && (src[1] == 'x' || src[1] == 'X')) { + if (caml_float_of_hex(src + 2, &d) == -1) + caml_failwith("float_of_string"); + return caml_copy_double(sign < 0 ? -d : d); + } + /* Remove '_' characters before calling strtod () */ len = caml_string_length(vs); buf = len < sizeof(parse_buffer) ? parse_buffer : caml_stat_alloc(len + 1); src = String_val(vs); @@ -147,6 +281,7 @@ CAMLprim value caml_float_of_string(value vs) } *dst = 0; if (dst == buf) goto error; + /* Convert using strtod */ d = strtod((const char *) buf, &end); if (end != dst) goto error; if (buf != parse_buffer) caml_stat_free(buf); @@ -463,27 +598,23 @@ enum { FP_normal, FP_subnormal, FP_zero, FP_infinite, FP_nan }; value caml_classify_float_unboxed(double vd) { - /* Cygwin 1.3 has problems with fpclassify (PR#1293), so don't use it */ - /* FIXME Cygwin 1.3 is ancient! Revisit this decision. */ - - /* Informal benchmarking (see GPR#272) suggests that the emulation - version is faster than calling the libc. We could switch to it, - and also provide an even faster version for 64-bit systems as - suggested by XL. -- AF */ - -#if defined(fpclassify) && !defined(__CYGWIN__) && !defined(__MINGW32__) - switch (fpclassify(vd)) { - case FP_NAN: - return Val_int(FP_nan); - case FP_INFINITE: - return Val_int(FP_infinite); - case FP_ZERO: - return Val_int(FP_zero); - case FP_SUBNORMAL: - return Val_int(FP_subnormal); - default: /* case FP_NORMAL */ - return Val_int(FP_normal); +#ifdef ARCH_SIXTYFOUR + union { double d; uint64_t i; } u; + uint64_t n; + uint32_t e; + + u.d = vd; + n = u.i << 1; /* shift sign bit off */ + if (n == 0) return Val_int(FP_zero); + e = n >> 53; /* extract exponent */ + if (e == 0) return Val_int(FP_subnormal); + if (e == 0x7FF) { + if (n << 11 == 0) /* shift exponent off */ + return Val_int(FP_infinite); + else + return Val_int(FP_nan); } + return Val_int(FP_normal); #else union double_as_two_int32 u; uint32_t h, l; diff --git a/byterun/intern.c b/byterun/intern.c index 7b8d0497b6..23eaebce5d 100644 --- a/byterun/intern.c +++ b/byterun/intern.c @@ -30,27 +30,27 @@ #include "caml/misc.h" #include "caml/reverse.h" +#ifdef _MSC_VER +#define inline _inline +#endif + static unsigned char * intern_src; /* Reading pointer in block holding input data. */ -static unsigned char * intern_input; -/* Pointer to beginning of block holding input data. - Meaningful only if intern_input_malloced = 1. */ - -static int intern_input_malloced; -/* 1 if intern_input was allocated by caml_stat_alloc() - and needs caml_stat_free() on error, 0 otherwise. */ +static unsigned char * intern_input = NULL; +/* Pointer to beginning of block holding input data, + if non-NULL this pointer will be freed by the cleanup function. */ static header_t * intern_dest; /* Writing pointer in destination block */ -static char * intern_extra_block; +static char * intern_extra_block = NULL; /* If non-NULL, point to new heap chunk allocated with caml_alloc_for_heap. */ static asize_t obj_counter; /* Count how many objects seen so far */ -static value * intern_obj_table; +static value * intern_obj_table = NULL; /* The pointers to objects already seen */ static unsigned int intern_color; @@ -60,7 +60,7 @@ static header_t intern_header; /* Original header of the destination block. Meaningful only if intern_extra_block is NULL. */ -static value intern_block; +static value intern_block = 0; /* Point to the heap block allocated as destination block. Meaningful only if intern_extra_block is NULL. */ @@ -73,51 +73,96 @@ CAMLnoreturn_end; static void intern_free_stack(void); -#define Sign_extend_shift ((sizeof(intnat) - 1) * 8) -#define Sign_extend(x) (((intnat)(x) << Sign_extend_shift) >> Sign_extend_shift) - -#define read8u() (*intern_src++) -#define read8s() Sign_extend(*intern_src++) -#define read16u() \ - (intern_src += 2, \ - (intern_src[-2] << 8) + intern_src[-1]) -#define read16s() \ - (intern_src += 2, \ - (Sign_extend(intern_src[-2]) << 8) + intern_src[-1]) -#define read32u() \ - (intern_src += 4, \ - ((uintnat)(intern_src[-4]) << 24) + (intern_src[-3] << 16) + \ - (intern_src[-2] << 8) + intern_src[-1]) -#define read32s() \ - (intern_src += 4, \ - (Sign_extend(intern_src[-4]) << 24) + (intern_src[-3] << 16) + \ - (intern_src[-2] << 8) + intern_src[-1]) +static inline unsigned char read8u(void) +{ return *intern_src++; } -#ifdef ARCH_SIXTYFOUR -static intnat read64s(void) +static inline signed char read8s(void) +{ return *intern_src++; } + +static inline uint16_t read16u(void) { - intnat res; - int i; - res = 0; - for (i = 0; i < 8; i++) res = (res << 8) + intern_src[i]; + uint16_t res = (intern_src[0] << 8) + intern_src[1]; + intern_src += 2; + return res; +} + +static inline int16_t read16s(void) +{ + int16_t res = (intern_src[0] << 8) + intern_src[1]; + intern_src += 2; + return res; +} + +static inline uint32_t read32u(void) +{ + uint32_t res = + ((uint32_t)(intern_src[0]) << 24) + (intern_src[1] << 16) + + (intern_src[2] << 8) + intern_src[3]; + intern_src += 4; + return res; +} + +static inline int32_t read32s(void) +{ + int32_t res = + ((uint32_t)(intern_src[0]) << 24) + (intern_src[1] << 16) + + (intern_src[2] << 8) + intern_src[3]; + intern_src += 4; + return res; +} + +#ifdef ARCH_SIXTYFOUR +static uintnat read64u(void) +{ + uintnat res = + ((uintnat) (intern_src[0]) << 56) + + ((uintnat) (intern_src[1]) << 48) + + ((uintnat) (intern_src[2]) << 40) + + ((uintnat) (intern_src[3]) << 32) + + ((uintnat) (intern_src[4]) << 24) + + ((uintnat) (intern_src[5]) << 16) + + ((uintnat) (intern_src[6]) << 8) + + (uintnat) (intern_src[7]); intern_src += 8; return res; } #endif -#define readblock(dest,len) \ - (memmove((dest), intern_src, (len)), intern_src += (len)) +static inline void readblock(void * dest, intnat len) +{ + memcpy(dest, intern_src, len); + intern_src += len; +} + +static void intern_init(void * src, void * input) +{ + /* This is asserted at the beginning of demarshaling primitives. + If it fails, it probably means that an exception was raised + without calling intern_cleanup() during the previous demarshaling. */ + Assert (intern_input == NULL && intern_obj_table == NULL \ + && intern_extra_block == NULL && intern_block == 0); + intern_src = src; + intern_input = input; +} static void intern_cleanup(void) { - if (intern_input_malloced) caml_stat_free(intern_input); - if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); + if (intern_input != NULL) { + caml_stat_free(intern_input); + intern_input = NULL; + } + if (intern_obj_table != NULL) { + caml_stat_free(intern_obj_table); + intern_obj_table = NULL; + } if (intern_extra_block != NULL) { /* free newly allocated heap chunk */ caml_free_for_heap(intern_extra_block); + intern_extra_block = NULL; } else if (intern_block != 0) { /* restore original header for heap block, otherwise GC is confused */ Hd_val(intern_block) = intern_header; + intern_block = 0; } /* free the recursion stack */ intern_free_stack(); @@ -368,7 +413,7 @@ static void intern_rec(value *dest) break; case CODE_INT64: #ifdef ARCH_SIXTYFOUR - v = Val_long(read64s()); + v = Val_long((intnat) (read64u())); break; #else intern_cleanup(); @@ -389,21 +434,22 @@ static void intern_rec(value *dest) case CODE_SHARED32: ofs = read32u(); goto read_shared; +#ifdef ARCH_SIXTYFOUR + case CODE_SHARED64: + ofs = read64u(); + goto read_shared; +#endif case CODE_BLOCK32: header = (header_t) read32u(); tag = Tag_hd(header); size = Wosize_hd(header); goto read_block; - case CODE_BLOCK64: #ifdef ARCH_SIXTYFOUR - header = (header_t) read64s(); + case CODE_BLOCK64: + header = (header_t) read64u(); tag = Tag_hd(header); size = Wosize_hd(header); goto read_block; -#else - intern_cleanup(); - caml_failwith("input_value: data block too large"); - break; #endif case CODE_STRING8: len = read8u(); @@ -411,6 +457,11 @@ static void intern_rec(value *dest) case CODE_STRING32: len = read32u(); goto read_string; +#ifdef ARCH_SIXTYFOUR + case CODE_STRING64: + len = read64u(); + goto read_string; +#endif case CODE_DOUBLE_LITTLE: case CODE_DOUBLE_BIG: v = Val_hp(intern_dest); @@ -434,6 +485,12 @@ static void intern_rec(value *dest) case CODE_DOUBLE_ARRAY32_BIG: len = read32u(); goto read_double_array; +#ifdef ARCH_SIXTYFOUR + case CODE_DOUBLE_ARRAY64_LITTLE: + case CODE_DOUBLE_ARRAY64_BIG: + len = read64u(); + goto read_double_array; +#endif case CODE_CODEPOINTER: ofs = read32u(); readblock(digest, 16); @@ -507,9 +564,8 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects) mlsize_t wosize; if (whsize == 0) { - intern_obj_table = NULL; - intern_extra_block = NULL; - intern_block = 0; + Assert (intern_extra_block == NULL && intern_block == 0 + && intern_obj_table == NULL); return; } wosize = Wosize_whsize(whsize); @@ -518,9 +574,13 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects) asize_t request = ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log; intern_extra_block = caml_alloc_for_heap(request); - if (intern_extra_block == NULL) caml_raise_out_of_memory(); + if (intern_extra_block == NULL) { + intern_cleanup(); + caml_raise_out_of_memory(); + } intern_color = caml_allocation_color(intern_extra_block); intern_dest = (header_t *) intern_extra_block; + Assert (intern_block == 0); } else { /* this is a specialised version of caml_alloc from alloc.c */ if (wosize == 0){ @@ -528,21 +588,29 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects) }else if (wosize <= Max_young_wosize){ intern_block = caml_alloc_small (wosize, String_tag); }else{ - intern_block = caml_alloc_shr (wosize, String_tag); + intern_block = caml_alloc_shr_no_raise (wosize, String_tag); /* do not do the urgent_gc check here because it might darken intern_block into gray and break the Assert 3 lines down */ + if (intern_block == 0) { + intern_cleanup(); + caml_raise_out_of_memory(); + } } intern_header = Hd_val(intern_block); intern_color = Color_hd(intern_header); Assert (intern_color == Caml_white || intern_color == Caml_black); intern_dest = (header_t *) Hp_val(intern_block); - intern_extra_block = NULL; + Assert (intern_extra_block == NULL); } obj_counter = 0; - if (num_objects > 0) - intern_obj_table = (value *) caml_stat_alloc(num_objects * sizeof(value)); - else - intern_obj_table = NULL; + if (num_objects > 0) { + intern_obj_table = (value *) malloc(num_objects * sizeof(value)); + if (intern_obj_table == NULL) { + intern_cleanup(); + caml_raise_out_of_memory(); + } + } else + Assert(intern_obj_table == NULL); } static void intern_add_to_heap(mlsize_t whsize) @@ -554,6 +622,7 @@ static void intern_add_to_heap(mlsize_t whsize) ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log; header_t * end_extra_block = (header_t *) intern_extra_block + Wsize_bsize(request); + Assert(intern_block == 0); Assert(intern_dest <= end_extra_block); if (intern_dest < end_extra_block){ caml_make_free_blocks ((value *) intern_dest, @@ -562,49 +631,105 @@ static void intern_add_to_heap(mlsize_t whsize) caml_allocated_words += Wsize_bsize ((char *) intern_dest - intern_extra_block); caml_add_to_heap(intern_extra_block); + intern_extra_block = NULL; // To prevent intern_cleanup freeing it + } else { + intern_block = 0; // To prevent intern_cleanup rewriting its header } } +/* Parsing the header */ + +struct marshal_header { + uint32_t magic; + int header_len; + uintnat data_len; + uintnat num_objects; + uintnat whsize; +}; + +static void caml_parse_header(char * fun_name, + /*out*/ struct marshal_header * h) +{ + char errmsg[100]; + + h->magic = read32u(); + switch(h->magic) { + case Intext_magic_number_small: + h->header_len = 20; + h->data_len = read32u(); + h->num_objects = read32u(); +#ifdef ARCH_SIXTYFOUR + read32u(); + h->whsize = read32u(); +#else + h->whsize = read32u(); + read32u(); +#endif + break; + case Intext_magic_number_big: +#ifdef ARCH_SIXTYFOUR + h->header_len = 32; + read32u(); + h->data_len = read64u(); + h->num_objects = read64u(); + h->whsize = read64u(); +#else + errmsg[sizeof(errmsg) - 1] = 0; + snprintf(errmsg, sizeof(errmsg) - 1, + "%s: object too large to be read back on a 32-bit platform", + fun_name); + caml_failwith(errmsg); +#endif + break; + default: + errmsg[sizeof(errmsg) - 1] = 0; + snprintf(errmsg, sizeof(errmsg) - 1, + "%s: bad object", + fun_name); + caml_failwith(errmsg); + } +} + +/* Reading from a channel */ + value caml_input_val(struct channel *chan) { - uint32_t magic; - mlsize_t block_len, num_objects, whsize; + char header[32]; + struct marshal_header h; char * block; value res; if (! caml_channel_binary_mode(chan)) caml_failwith("input_value: not a binary channel"); - magic = caml_getword(chan); - if (magic != Intext_magic_number) caml_failwith("input_value: bad object"); - block_len = caml_getword(chan); - num_objects = caml_getword(chan); -#ifdef ARCH_SIXTYFOUR - caml_getword(chan); /* skip size_32 */ - whsize = caml_getword(chan); -#else - whsize = caml_getword(chan); - caml_getword(chan); /* skip size_64 */ -#endif + /* Read and parse the header */ + if (caml_really_getblock(chan, header, 20) == 0) + caml_failwith("input_value: truncated object"); + intern_src = (unsigned char *) header; + if (read32u() == Intext_magic_number_big) { + /* Finish reading the header */ + if (caml_really_getblock(chan, header + 20, 32 - 20) == 0) + caml_failwith("input_value: truncated object"); + } + intern_src = (unsigned char *) header; + caml_parse_header("input_value", &h); /* Read block from channel */ - block = caml_stat_alloc(block_len); + block = caml_stat_alloc(h.data_len); /* During [caml_really_getblock], concurrent [caml_input_val] operations can take place (via signal handlers or context switching in systhreads), and [intern_input] may change. So, wait until [caml_really_getblock] is over before using [intern_input] and the other global vars. */ - if (caml_really_getblock(chan, block, block_len) == 0) { + if (caml_really_getblock(chan, block, h.data_len) == 0) { caml_stat_free(block); caml_failwith("input_value: truncated object"); } - intern_input = (unsigned char *) block; - intern_input_malloced = 1; - intern_src = intern_input; - intern_alloc(whsize, num_objects); + /* Initialize global state */ + intern_init(block, block); + intern_alloc(h.whsize, h.num_objects); /* Fill it in */ intern_rec(&res); - intern_add_to_heap(whsize); + intern_add_to_heap(h.whsize); /* Free everything */ - caml_stat_free(intern_input); - if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); + intern_cleanup(); return caml_check_urgent_gc(res); } @@ -620,30 +745,27 @@ CAMLprim value caml_input_value(value vchan) CAMLreturn (res); } +/* Reading from memory-resident blocks */ + CAMLexport value caml_input_val_from_string(value str, intnat ofs) { CAMLparam1 (str); - mlsize_t num_objects, whsize; CAMLlocal1 (obj); + struct marshal_header h; - intern_src = &Byte_u(str, ofs + 2*4); - intern_input_malloced = 0; - num_objects = read32u(); -#ifdef ARCH_SIXTYFOUR - intern_src += 4; /* skip size_32 */ - whsize = read32u(); -#else - whsize = read32u(); - intern_src += 4; /* skip size_64 */ -#endif + /* Initialize global state */ + intern_init(&Byte_u(str, ofs), NULL); + caml_parse_header("input_val_from_string", &h); + if (ofs + h.header_len + h.data_len > caml_string_length(str)) + caml_failwith("input_val_from_string: bad length"); /* Allocate result */ - intern_alloc(whsize, num_objects); - intern_src = &Byte_u(str, ofs + 5*4); /* If a GC occurred */ + intern_alloc(h.whsize, h.num_objects); + intern_src = &Byte_u(str, ofs + h.header_len); /* If a GC occurred */ /* Fill it in */ intern_rec(&obj); - intern_add_to_heap(whsize); + intern_add_to_heap(h.whsize); /* Free everything */ - if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); + intern_cleanup(); CAMLreturn (caml_check_urgent_gc(obj)); } @@ -652,83 +774,77 @@ CAMLprim value caml_input_value_from_string(value str, value ofs) return caml_input_val_from_string(str, Long_val(ofs)); } -static value input_val_from_block(void) +static value input_val_from_block(struct marshal_header * h) { - mlsize_t num_objects, whsize; value obj; - - num_objects = read32u(); -#ifdef ARCH_SIXTYFOUR - intern_src += 4; /* skip size_32 */ - whsize = read32u(); -#else - whsize = read32u(); - intern_src += 4; /* skip size_64 */ -#endif /* Allocate result */ - intern_alloc(whsize, num_objects); + intern_alloc(h->whsize, h->num_objects); /* Fill it in */ intern_rec(&obj); - intern_add_to_heap(whsize); + intern_add_to_heap(h->whsize); /* Free internal data structures */ - if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); + intern_cleanup(); return caml_check_urgent_gc(obj); } CAMLexport value caml_input_value_from_malloc(char * data, intnat ofs) { - uint32_t magic; - value obj; + struct marshal_header h; - intern_input = (unsigned char *) data; - intern_src = intern_input + ofs; - intern_input_malloced = 1; - magic = read32u(); - if (magic != Intext_magic_number) - caml_failwith("input_value_from_malloc: bad object"); - intern_src += 4; /* Skip block_len */ - obj = input_val_from_block(); - /* Free the input */ - caml_stat_free(intern_input); - return obj; + intern_init(data + ofs, data); + + caml_parse_header("input_value_from_malloc", &h); + + return input_val_from_block(&h); } /* [len] is a number of bytes */ CAMLexport value caml_input_value_from_block(char * data, intnat len) { - uint32_t magic; - mlsize_t block_len; - value obj; + struct marshal_header h; - intern_input = (unsigned char *) data; - intern_src = intern_input; - intern_input_malloced = 0; - magic = read32u(); - if (magic != Intext_magic_number) - caml_failwith("input_value_from_block: bad object"); - block_len = read32u(); - if (5*4 + block_len > len) - caml_failwith("input_value_from_block: bad block length"); - obj = input_val_from_block(); - return obj; + /* Initialize global state */ + intern_init(data, NULL); + caml_parse_header("input_value_from_block", &h); + if (h.header_len + h.data_len > len) + caml_failwith("input_val_from_block: bad length"); + return input_val_from_block(&h); } /* [ofs] is a [value] that represents a number of bytes result is a [value] that represents a number of bytes -*/ + To handle both the small and the big format, + we assume 20 bytes are available at [buff + ofs], + and we return the data size + the length of the part of the header + that remains to be read. */ + CAMLprim value caml_marshal_data_size(value buff, value ofs) { uint32_t magic; - mlsize_t block_len; + int header_len; + uintnat data_len; intern_src = &Byte_u(buff, Long_val(ofs)); - intern_input_malloced = 0; magic = read32u(); - if (magic != Intext_magic_number){ + switch(magic) { + case Intext_magic_number_small: + header_len = 20; + data_len = read32u(); + break; + case Intext_magic_number_big: +#ifdef ARCH_SIXTYFOUR + header_len = 32; + read32u(); + data_len = read64u(); +#else + caml_failwith("Marshal.data_size: " + "object too large to be read back on a 32-bit platform"); +#endif + break; + default: caml_failwith("Marshal.data_size: bad object"); } - block_len = read32u(); - return Val_long(block_len); + return Val_long((header_len - 20) + data_len); } /* Resolution of code pointers */ @@ -829,7 +945,7 @@ CAMLexport double caml_deserialize_float_8(void) CAMLexport void caml_deserialize_block_1(void * data, intnat len) { - memmove(data, intern_src, len); + memcpy(data, intern_src, len); intern_src += len; } @@ -841,7 +957,7 @@ CAMLexport void caml_deserialize_block_2(void * data, intnat len) Reverse_16(q, p); intern_src = p; #else - memmove(data, intern_src, len * 2); + memcpy(data, intern_src, len * 2); intern_src += len * 2; #endif } @@ -854,7 +970,7 @@ CAMLexport void caml_deserialize_block_4(void * data, intnat len) Reverse_32(q, p); intern_src = p; #else - memmove(data, intern_src, len * 4); + memcpy(data, intern_src, len * 4); intern_src += len * 4; #endif } @@ -867,7 +983,7 @@ CAMLexport void caml_deserialize_block_8(void * data, intnat len) Reverse_64(q, p); intern_src = p; #else - memmove(data, intern_src, len * 8); + memcpy(data, intern_src, len * 8); intern_src += len * 8; #endif } @@ -875,7 +991,7 @@ CAMLexport void caml_deserialize_block_8(void * data, intnat len) CAMLexport void caml_deserialize_block_float_8(void * data, intnat len) { #if ARCH_FLOAT_ENDIANNESS == 0x01234567 - memmove(data, intern_src, len * 8); + memcpy(data, intern_src, len * 8); intern_src += len * 8; #elif ARCH_FLOAT_ENDIANNESS == 0x76543210 unsigned char * p, * q; diff --git a/byterun/memory.c b/byterun/memory.c index 7e9d4ab209..15039b3cc9 100644 --- a/byterun/memory.c +++ b/byterun/memory.c @@ -26,6 +26,10 @@ #include "caml/mlvalues.h" #include "caml/signals.h" +#ifdef _MSC_VER +#define inline _inline +#endif + extern uintnat caml_percent_free; /* major_gc.c */ /* Page table management */ @@ -405,17 +409,25 @@ color_t caml_allocation_color (void *hp) } } -CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag) +static inline value caml_alloc_shr_aux (mlsize_t wosize, tag_t tag, + int raise_oom) { header_t *hp; value *new_block; - if (wosize > Max_wosize) caml_raise_out_of_memory (); + if (wosize > Max_wosize) { + if (raise_oom) + caml_raise_out_of_memory (); + else + return 0; + } hp = caml_fl_allocate (wosize); if (hp == NULL){ new_block = expand_heap (wosize); if (new_block == NULL) { - if (caml_in_minor_collection) + if (!raise_oom) + return 0; + else if (caml_in_minor_collection) caml_fatal_error ("Fatal error: out of memory.\n"); else caml_raise_out_of_memory (); @@ -452,6 +464,16 @@ CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag) return Val_hp (hp); } +CAMLexport value caml_alloc_shr_no_raise (mlsize_t wosize, tag_t tag) +{ + return caml_alloc_shr_aux(wosize, tag, 0); +} + +CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag) +{ + return caml_alloc_shr_aux(wosize, tag, 1); +} + /* Dependent memory is all memory blocks allocated out of the heap that depend on the GC (and finalizers) for deallocation. For the GC to take dependent memory into account when computing diff --git a/byterun/meta.c b/byterun/meta.c index 32cd6dd717..0e0864a3ac 100644 --- a/byterun/meta.c +++ b/byterun/meta.c @@ -210,6 +210,12 @@ value caml_reify_bytecode(value prog, value len) return Val_unit; /* not reached */ } +value caml_static_release_bytecode(value prog, value len) +{ + caml_invalid_argument("Meta.static_release_bytecode"); + return Val_unit; /* not reached */ +} + value * caml_stack_low; value * caml_stack_high; value * caml_stack_threshold; diff --git a/byterun/sys.c b/byterun/sys.c index 304e91661d..867c16981b 100644 --- a/byterun/sys.c +++ b/byterun/sys.c @@ -339,6 +339,10 @@ CAMLprim value caml_sys_system_command(value command) int status, retcode; char *buf; + if (! caml_string_is_c_safe (command)) { + errno = EINVAL; + caml_sys_error(command); + } buf = caml_strdup(String_val(command)); caml_enter_blocking_section (); status = system(buf); diff --git a/config/auto-aux/cckind.c b/config/auto-aux/cckind.c index 2385a53bcb..e3595e915d 100644 --- a/config/auto-aux/cckind.c +++ b/config/auto-aux/cckind.c @@ -20,7 +20,7 @@ #if defined(__INTEL_COMPILER) icc __INTEL_COMPILER #elif defined(__clang_major__) && defined(__clang_minor__) -clang __clang_major __clang_minor__ +clang __clang_major__ __clang_minor__ #elif defined(__GNUC__) && defined(__GNUC_MINOR__) gcc __GNUC__ __GNUC_MINOR__ #else diff --git a/config/m-nt.h b/config/m-nt.h index a80b0ac5e7..9af624c467 100644 --- a/config/m-nt.h +++ b/config/m-nt.h @@ -40,4 +40,8 @@ #endif #define ARCH_INT64_PRINTF_FORMAT "I64" +#if !defined(__MINGW32__) && !defined(inline) +#define inline __inline +#endif + #undef NONSTANDARD_DIV_MOD @@ -310,13 +310,13 @@ case "$ccfamily" in clang-*) bytecccompopts="-O2 -fno-strict-aliasing -fwrapv $gcc_warnings";; gcc-[012]-*) - # Some versions known to miscompile OCaml, e,g, 2.7,2.1, some 2.96. + # Some versions known to miscompile OCaml, e,g, 2.7.2.1, some 2.96. # Plus: C99 support unknown. err "This version of GCC is too old. Please use GCC version 4.2 or above.";; gcc-3-*|gcc-4-[01]) # No -fwrapv option before GCC 3.4. # Known problems with -fwrapv fixed in 4.2 only. - wrn "This verion of GCC is rather old. Reducing optimization level." + wrn "This version of GCC is rather old. Reducing optimization level." wrn "Consider using GCC version 4.2 or above." bytecccompopts="-std=gnu99 -O $gcc_warnings";; gcc-*) @@ -763,6 +763,7 @@ if test $with_sharedlibs = "yes"; then natdynlink=true fi;; x86_64-*-darwin*) natdynlink=true;; + s390x*-*-linux*) natdynlink=true;; powerpc*-*-linux*) natdynlink=true;; sparc*-*-linux*) natdynlink=true;; i686-*-kfreebsd*) natdynlink=true;; @@ -823,6 +824,7 @@ case "$target" in system=elf;; powerpc-*-netbsd*) arch=power; model=ppc; system=elf;; powerpc-*-openbsd*) arch=power; model=ppc; system=bsd_elf;; + s390x*-*-linux*) arch=s390x; model=z10; system=elf;; armv6*-*-linux-gnueabihf) arch=arm; model=armv6; system=linux_eabihf;; arm*-*-linux-gnueabihf) arch=arm; system=linux_eabihf;; armv7*-*-linux-gnueabi) arch=arm; model=armv7; system=linux_eabi;; @@ -899,6 +901,8 @@ case "$arch,$system" in as="${TOOLPREF}as -mppc" aspp="${TOOLPREF}gcc -m32 -c" fi;; + s390x,elf) as="${TOOLPREF}as -m 64 -march=$model" + aspp="${TOOLPREF}gcc -c -Wa,-march=$model";; sparc,solaris) as="${TOOLPREF}as" case "$cc" in *gcc*) aspp="${TOOLPREF}gcc -c";; diff --git a/debugger/Makefile.shared b/debugger/Makefile.shared index 88405a4c29..05d8d50b06 100644 --- a/debugger/Makefile.shared +++ b/debugger/Makefile.shared @@ -30,8 +30,10 @@ INCLUDES=\ OTHEROBJS=\ $(UNIXDIR)/unix.cma \ - ../utils/misc.cmo ../utils/config.cmo ../utils/tbl.cmo \ - ../utils/clflags.cmo ../utils/consistbl.cmo ../utils/warnings.cmo \ + ../utils/config.cmo ../utils/tbl.cmo \ + ../utils/clflags.cmo ../utils/misc.cmo \ + ../utils/consistbl.cmo ../utils/warnings.cmo \ + ../utils/terminfo.cmo \ ../parsing/location.cmo ../parsing/longident.cmo ../parsing/docstrings.cmo \ ../parsing/ast_helper.cmo ../parsing/ast_mapper.cmo \ ../parsing/attr_helper.cmo \ diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml index 16d6e9f2b4..996917fb62 100644 --- a/debugger/loadprinter.ml +++ b/debugger/loadprinter.ml @@ -76,6 +76,9 @@ let rec loadfiles ppf name = | Not_found -> fprintf ppf "Cannot find file %s@." name; false + | Sys_error msg -> + fprintf ppf "%s: %s@." name msg; + false | Dynlink.Error e -> raise(Error(Load_failure e)) diff --git a/ocamlbuild/ocaml_specific.ml b/ocamlbuild/ocaml_specific.ml index b902810ad7..a73b7a5c92 100644 --- a/ocamlbuild/ocaml_specific.ml +++ b/ocamlbuild/ocaml_specific.ml @@ -698,15 +698,25 @@ ocaml_lib ~extern:true ~tag_name:"use_toplevel" "toplevellib";; ocaml_lib ~extern:true ~dir:"+ocamldoc" "ocamldoc";; ocaml_lib ~extern:true ~dir:"+ocamlbuild" ~tag_name:"use_ocamlbuild" "ocamlbuildlib";; -ocaml_lib ~extern:true ~dir:"+camlp4" ~tag_name:"use_camlp4" "camlp4lib";; -ocaml_lib ~extern:true ~dir:"+camlp4" ~tag_name:"use_old_camlp4" "camlp4";; -ocaml_lib ~extern:true ~dir:"+camlp4" ~tag_name:"use_camlp4_full" "camlp4fulllib";; +let camlp4dir = + Findlib.( + try + if sys_command "sh -c 'ocamlfind list >/dev/null' 2>/dev/null" != 0 + then raise (Findlib_error Cannot_run_ocamlfind); + (query "camlp4").location + with Findlib_error _ -> + "+camlp4" + );; + +ocaml_lib ~extern:true ~dir:camlp4dir ~tag_name:"use_camlp4" "camlp4lib";; +ocaml_lib ~extern:true ~dir:camlp4dir ~tag_name:"use_old_camlp4" "camlp4";; +ocaml_lib ~extern:true ~dir:camlp4dir ~tag_name:"use_camlp4_full" "camlp4fulllib";; flag ["ocaml"; "compile"; "use_camlp4_full"] - (S[A"-I"; A"+camlp4/Camlp4Parsers"; - A"-I"; A"+camlp4/Camlp4Printers"; - A"-I"; A"+camlp4/Camlp4Filters"]);; -flag ["ocaml"; "use_camlp4_bin"; "link"; "byte"] (A"+camlp4/Camlp4Bin.cmo");; -flag ["ocaml"; "use_camlp4_bin"; "link"; "native"] (A"+camlp4/Camlp4Bin.cmx");; + (S[A"-I"; A(camlp4dir^"/Camlp4Parsers"); + A"-I"; A(camlp4dir^"/Camlp4Printers"); + A"-I"; A(camlp4dir^"/Camlp4Filters")]);; +flag ["ocaml"; "use_camlp4_bin"; "link"; "byte"] (A(camlp4dir^"/Camlp4Bin.cmo"));; +flag ["ocaml"; "use_camlp4_bin"; "link"; "native"] (A(camlp4dir^"/Camlp4Bin.cmx"));; flag ["ocaml"; "debug"; "compile"; "byte"] (A "-g");; flag ["ocaml"; "debug"; "link"; "byte"; "program"] (A "-g");; diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index 26292b8a79..436c7502ec 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -797,7 +797,7 @@ module Analyser = Odoc_messages.object_end in let param_exps = List.fold_left - (fun acc -> fun (_, exp_opt, _) -> + (fun acc -> fun (_, exp_opt) -> match exp_opt with None -> acc | Some e -> acc @ [e]) @@ -1464,7 +1464,7 @@ module Analyser = ) | Parsetree.Pstr_recmodule mods -> - (* FIXME Here problem: no link with module types + (* FIXME Here problem: no link with module types in module constraints *) let new_env = List.fold_left diff --git a/ocamldoc/odoc_comments.ml b/ocamldoc/odoc_comments.ml index c39cb51bf9..236d860a37 100644 --- a/ocamldoc/odoc_comments.ml +++ b/ocamldoc/odoc_comments.ml @@ -28,7 +28,7 @@ module type Texter = module Info_retriever = functor (MyTexter : Texter) -> struct - let create_see s = + let create_see file s = try let lexbuf = Lexing.from_string s in let (see_ref, s) = Odoc_parser.see_info Odoc_see_lexer.main lexbuf in @@ -64,7 +64,7 @@ module Info_retriever = i_desc = (match desc with "" -> None | _ -> Some (MyTexter.text_of_string desc)); i_authors = !Odoc_comments_global.authors; i_version = !Odoc_comments_global.version; - i_sees = (List.map create_see !Odoc_comments_global.sees) ; + i_sees = (List.map (create_see file) !Odoc_comments_global.sees) ; i_since = !Odoc_comments_global.since; i_before = Odoc_merge.merge_before_tags (List.map (fun (n, s) -> @@ -87,19 +87,16 @@ module Info_retriever = !Odoc_comments_global.customs) } ) - with - Failure s -> - incr Odoc_global.errors ; - Printf.eprintf "File %S, line %d:\n%s\n%!" file (!Odoc_lexer.line_number + 1) s; - (0, None) - | Odoc_text.Text_syntax (l, c, s) -> - incr Odoc_global.errors ; - prerr_endline (file^" : "^(Odoc_messages.text_parse_error l c s)); - (0, None) - | _ -> - incr Odoc_global.errors ; - prerr_endline (file^" : "^Odoc_messages.parse_error^"\n"); - (0, None) + with e -> + let (l, c, message) = match e with + | Failure s -> (!Odoc_lexer.line_number + 1, 0, s) + | Odoc_text.Text_syntax (l, c, s) -> (l, c, Odoc_messages.text_parse_error l c s) + | _other -> (0, 0, Odoc_messages.parse_error) + in begin + incr Odoc_global.errors; + prerr_endline (Odoc_messages.error_location file l c ^ message); + (0, None) + end (** This function takes a string where a simple comment may has been found. It returns false if there is a blank line or the first comment is a special one, or if there is diff --git a/ocamldoc/odoc_messages.ml b/ocamldoc/odoc_messages.ml index f2a6dbe6b5..cdfd4ff5a4 100644 --- a/ocamldoc/odoc_messages.ml +++ b/ocamldoc/odoc_messages.ml @@ -233,6 +233,9 @@ let help = " Display this list of options" let warning = "Warning" +let error_location file l c = + Printf.sprintf "File \"%s\", line %d, character %d:\n" file l c + let bad_magic_number = "Bad magic number for this ocamldoc dump!\n"^ "This dump was not created by this version of OCamldoc." @@ -244,10 +247,7 @@ let errors_occured n = (string_of_int n)^" error(s) encountered" let parse_error = "Parse error" let text_parse_error l c s = let lines = Str.split (Str.regexp_string "\n") s in - "Syntax error in text:\n"^s^"\n"^ - "line "^(string_of_int l)^", character "^(string_of_int c)^":\n"^ - (List.nth lines l)^"\n"^ - (String.make c ' ')^"^" + (List.nth lines l) ^ "\n" ^ (String.make c ' ') ^ "^" let file_not_found_in_paths paths name = Printf.sprintf "No file %s found in the load paths: \n%s" diff --git a/otherlibs/str/str.mli b/otherlibs/str/str.mli index 448cbd5ac3..49aca742bf 100644 --- a/otherlibs/str/str.mli +++ b/otherlibs/str/str.mli @@ -36,10 +36,10 @@ val regexp : string -> regexp To include a [\]] character in a set, make it the first character of the set. To include a [-] character in a set, make it the first or the last character of the set. - - [^ ] Matches at beginning of line (either at the beginning of - the matched string, or just after a newline character). - - [$ ] Matches at end of line (either at the end of the matched - string, or just before a newline character). + - [^ ] Matches at beginning of line: either at the beginning of + the matched string, or just after a '\n' character. + - [$ ] Matches at end of line: either at the end of the matched + string, or just before a '\n' character. - [\| ] (infix) Alternative between two expressions. - [\(..\)] Grouping and naming of the enclosed expression. - [\1 ] The text matched by the first [\(...\)] expression diff --git a/otherlibs/systhreads/st_stubs.c b/otherlibs/systhreads/st_stubs.c index 6ee4bbc199..a2b0f94d85 100644 --- a/otherlibs/systhreads/st_stubs.c +++ b/otherlibs/systhreads/st_stubs.c @@ -228,7 +228,7 @@ static void caml_io_mutex_lock(struct channel *chan) st_mutex mutex = chan->mutex; if (mutex == NULL) { - st_mutex_create(&mutex); + st_check_error(st_mutex_create(&mutex), "channel locking"); /*PR#7038*/ chan->mutex = mutex; } /* PR#4351: first try to acquire mutex without releasing the master lock */ diff --git a/otherlibs/threads/unix.ml b/otherlibs/threads/unix.ml index a397ec404f..aec9bc6977 100644 --- a/otherlibs/threads/unix.ml +++ b/otherlibs/threads/unix.ml @@ -472,6 +472,7 @@ external localtime : float -> tm = "unix_localtime" external mktime : tm -> float * tm = "unix_mktime" external alarm : int -> int = "unix_alarm" +let sleepf = delay let sleep secs = delay (float secs) external times : unit -> process_times = "unix_times" diff --git a/otherlibs/unix/addrofstr.c b/otherlibs/unix/addrofstr.c index 207e1cd990..38161bac90 100644 --- a/otherlibs/unix/addrofstr.c +++ b/otherlibs/unix/addrofstr.c @@ -22,8 +22,10 @@ CAMLprim value unix_inet_addr_of_string(value s) { + if (! caml_string_is_c_safe(s)) failwith("inet_addr_of_string"); #if defined(HAS_IPV6) #ifdef _WIN32 + { CAMLparam1(s); CAMLlocal1(vres); struct addrinfo hints; @@ -55,7 +57,9 @@ CAMLprim value unix_inet_addr_of_string(value s) } freeaddrinfo(res); CAMLreturn (vres); + } #else + { struct in_addr address; struct in6_addr address6; if (inet_pton(AF_INET, String_val(s), &address) > 0) @@ -64,17 +68,22 @@ CAMLprim value unix_inet_addr_of_string(value s) return alloc_inet6_addr(&address6); else failwith("inet_addr_of_string"); + } #endif #elif defined(HAS_INET_ATON) + { struct in_addr address; if (inet_aton(String_val(s), &address) == 0) failwith("inet_addr_of_string"); return alloc_inet_addr(&address); + } #else + { struct in_addr address; address.s_addr = inet_addr(String_val(s)); if (address.s_addr == (uint32_t) -1) failwith("inet_addr_of_string"); return alloc_inet_addr(&address); + } #endif } diff --git a/otherlibs/unix/cstringv.c b/otherlibs/unix/cstringv.c index 0e61491853..29e89a3428 100644 --- a/otherlibs/unix/cstringv.c +++ b/otherlibs/unix/cstringv.c @@ -11,16 +11,20 @@ /* */ /***********************************************************************/ +#include <errno.h> #include <caml/mlvalues.h> #include <caml/memory.h> #include "unixsupport.h" -char ** cstringvect(value arg) +char ** cstringvect(value arg, char * cmdname) { char ** res; mlsize_t size, i; size = Wosize_val(arg); + for (i = 0; i < size; i++) + if (! caml_string_is_c_safe(Field(arg, i))) + unix_error(EINVAL, cmdname, Field(arg, i)); res = (char **) caml_stat_alloc((size + 1) * sizeof(char *)); for (i = 0; i < size; i++) res[i] = String_val(Field(arg, i)); res[size] = NULL; diff --git a/otherlibs/unix/execv.c b/otherlibs/unix/execv.c index 026c11bc02..dcf45cd329 100644 --- a/otherlibs/unix/execv.c +++ b/otherlibs/unix/execv.c @@ -19,7 +19,7 @@ CAMLprim value unix_execv(value path, value args) { char ** argv; caml_unix_check_path(path, "execv"); - argv = cstringvect(args); + argv = cstringvect(args, "execv"); (void) execv(String_val(path), argv); stat_free((char *) argv); uerror("execv", path); diff --git a/otherlibs/unix/execve.c b/otherlibs/unix/execve.c index 539e8086aa..c31bf84fb6 100644 --- a/otherlibs/unix/execve.c +++ b/otherlibs/unix/execve.c @@ -20,8 +20,8 @@ CAMLprim value unix_execve(value path, value args, value env) char ** argv; char ** envp; caml_unix_check_path(path, "execve"); - argv = cstringvect(args); - envp = cstringvect(env); + argv = cstringvect(args, "execve"); + envp = cstringvect(env, "execve"); (void) execve(String_val(path), argv, envp); stat_free((char *) argv); stat_free((char *) envp); diff --git a/otherlibs/unix/execvp.c b/otherlibs/unix/execvp.c index 4a068eb735..32b19297e3 100644 --- a/otherlibs/unix/execvp.c +++ b/otherlibs/unix/execvp.c @@ -23,7 +23,7 @@ CAMLprim value unix_execvp(value path, value args) { char ** argv; caml_unix_check_path(path, "execvp"); - argv = cstringvect(args); + argv = cstringvect(args, "execvp"); (void) execvp(String_val(path), argv); stat_free((char *) argv); uerror("execvp", path); @@ -36,9 +36,9 @@ CAMLprim value unix_execvpe(value path, value args, value env) char ** argv; char ** saved_environ; caml_unix_check_path(path, "execvpe"); - argv = cstringvect(args); + argv = cstringvect(args, "execvpe"); saved_environ = environ; - environ = cstringvect(env); + environ = cstringvect(env, "execvpe"); (void) execvp(String_val(path), argv); stat_free((char *) argv); stat_free((char *) environ); diff --git a/otherlibs/unix/getgr.c b/otherlibs/unix/getgr.c index 14338ccffc..988d19d763 100644 --- a/otherlibs/unix/getgr.c +++ b/otherlibs/unix/getgr.c @@ -40,6 +40,7 @@ static value alloc_group_entry(struct group *entry) CAMLprim value unix_getgrnam(value name) { struct group * entry; + if (! caml_string_is_c_safe(name)) raise_not_found(); entry = getgrnam(String_val(name)); if (entry == NULL) raise_not_found(); return alloc_group_entry(entry); diff --git a/otherlibs/unix/getpw.c b/otherlibs/unix/getpw.c index 82fb4d8fdf..e8f4dabc00 100644 --- a/otherlibs/unix/getpw.c +++ b/otherlibs/unix/getpw.c @@ -49,6 +49,7 @@ static value alloc_passwd_entry(struct passwd *entry) CAMLprim value unix_getpwnam(value name) { struct passwd * entry; + if (! caml_string_is_c_safe(name)) raise_not_found(); entry = getpwnam(String_val(name)); if (entry == (struct passwd *) NULL) raise_not_found(); return alloc_passwd_entry(entry); diff --git a/otherlibs/unix/initgroups.c b/otherlibs/unix/initgroups.c index ca3ed4c99e..4b5e9b221f 100644 --- a/otherlibs/unix/initgroups.c +++ b/otherlibs/unix/initgroups.c @@ -21,12 +21,15 @@ #ifdef HAS_UNISTD #include <unistd.h> #endif +#include <errno.h> #include <limits.h> #include <grp.h> #include "unixsupport.h" CAMLprim value unix_initgroups(value user, value group) { + if (! caml_string_is_c_safe(user)) + unix_error(EINVAL, "initgroups", user); if (initgroups(String_val(user), Int_val(group)) == -1) { uerror("initgroups", Nothing); } diff --git a/otherlibs/unix/readlink.c b/otherlibs/unix/readlink.c index 836718d1dc..4d6401766a 100644 --- a/otherlibs/unix/readlink.c +++ b/otherlibs/unix/readlink.c @@ -36,6 +36,7 @@ CAMLprim value unix_readlink(value path) char buffer[PATH_MAX]; int len; char * p; + caml_unix_check_path(path, "readlink"); p = caml_strdup(String_val(path)); caml_enter_blocking_section(); len = readlink(p, buffer, sizeof(buffer) - 1); diff --git a/otherlibs/unix/sleep.c b/otherlibs/unix/sleep.c index a39c5f829d..4a83396085 100644 --- a/otherlibs/unix/sleep.c +++ b/otherlibs/unix/sleep.c @@ -15,10 +15,55 @@ #include <caml/signals.h> #include "unixsupport.h" -CAMLprim value unix_sleep(value t) +#include <errno.h> +#include <time.h> +#ifdef HAS_SELECT +#include <sys/types.h> +#include <sys/time.h> +#ifdef HAS_SYS_SELECT_H +#include <sys/select.h> +#endif +#endif + +CAMLprim value unix_sleep(value duration) { - enter_blocking_section(); - sleep(Int_val(t)); - leave_blocking_section(); + double d = Double_val(duration); + if (d <= 0.0) return Val_unit; +#if _POSIX_C_SOURCE >= 199309L + { + struct timespec t; + int ret; + enter_blocking_section(); + t.tv_sec = (time_t) d; + t.tv_nsec = (d - t.tv_sec) * 1e9; + do { + ret = nanosleep(&t, &t); + } while (ret == -1 && errno == EINTR); + leave_blocking_section(); + if (ret == -1) uerror("sleep", Nothing); + } +#elif defined(HAS_SELECT) + { + struct timeval t; + int ret; + enter_blocking_section(); + t.tv_sec = (time_t) d; + t.tv_usec = (d - t.tv_sec) * 1e6; + do { + ret = select(0, NULL, NULL, NULL, &t); + } while (ret == -1 && errno == EINTR); + leave_blocking_section(); + if (ret == -1) uerror("sleep", Nothing); + } +#else + /* Fallback implementation, resolution 1 second only. + We cannot reliably iterate until sleep() returns 0, because the + remaining time returned by sleep() is generally rounded up. */ + { + enter_blocking_section(); + sleep ((unsigned int) d); + leave_blocking_section(); + } +#endif return Val_unit; } diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml index d18b338adb..9e0f4cf832 100644 --- a/otherlibs/unix/unix.ml +++ b/otherlibs/unix/unix.ml @@ -427,7 +427,8 @@ external gmtime : float -> tm = "unix_gmtime" external localtime : float -> tm = "unix_localtime" external mktime : tm -> float * tm = "unix_mktime" external alarm : int -> int = "unix_alarm" -external sleep : int -> unit = "unix_sleep" +external sleepf : float -> unit = "unix_sleep" +let sleep duration = sleepf (float duration) external times : unit -> process_times = "unix_times" external utimes : string -> float -> float -> unit = "unix_utimes" diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli index dea5cb30be..a349d3d3a3 100644 --- a/otherlibs/unix/unix.mli +++ b/otherlibs/unix/unix.mli @@ -788,6 +788,9 @@ val alarm : int -> int val sleep : int -> unit (** Stop execution for the given number of seconds. *) +val sleepf : float -> unit +(** Stop execution for the given number of seconds. Like [sleep], + but fractions of seconds are supported. *) val times : unit -> process_times (** Return the execution times of the process. *) diff --git a/otherlibs/unix/unixsupport.h b/otherlibs/unix/unixsupport.h index 99ac539537..1ab9793f9f 100644 --- a/otherlibs/unix/unixsupport.h +++ b/otherlibs/unix/unixsupport.h @@ -41,7 +41,7 @@ extern void caml_unix_check_path(value path, char * cmdname); #define DIR_Val(v) *((DIR **) &Field(v, 0)) -extern char ** cstringvect(value arg); +extern char ** cstringvect(value arg, char * cmdname); #ifdef __cplusplus } diff --git a/otherlibs/unix/utimes.c b/otherlibs/unix/utimes.c index bf2ae2fb26..c9a4bfca49 100644 --- a/otherlibs/unix/utimes.c +++ b/otherlibs/unix/utimes.c @@ -32,6 +32,7 @@ CAMLprim value unix_utimes(value path, value atime, value mtime) struct utimbuf times, * t; char * p; int ret; + caml_unix_check_path(path, "utimes"); times.actime = Double_val(atime); times.modtime = Double_val(mtime); if (times.actime || times.modtime) @@ -60,8 +61,10 @@ CAMLprim value unix_utimes(value path, value atime, value mtime) struct timeval tv[2], * t; char * p; int ret; - double at = Double_val(atime); - double mt = Double_val(mtime); + double at, mt; + caml_unix_check_path(path, "utimes"); + at = Double_val(atime); + mt = Double_val(mtime); tv[0].tv_sec = at; tv[0].tv_usec = (at - tv[0].tv_sec) * 1000000; tv[1].tv_sec = mt; diff --git a/otherlibs/win32unix/createprocess.c b/otherlibs/win32unix/createprocess.c index f7e3b6bbba..64e2227dcf 100644 --- a/otherlibs/win32unix/createprocess.c +++ b/otherlibs/win32unix/createprocess.c @@ -15,6 +15,7 @@ #include "unixsupport.h" #include <windows.h> #include <caml/osdeps.h> +#include <errno.h> static int win_has_console(void); @@ -27,6 +28,10 @@ value win_create_process_native(value cmd, value cmdline, value env, int flags; caml_unix_check_path(cmd, "create_process"); + if (! caml_string_is_c_safe(cmdline)) + unix_error(EINVAL, "create_process", cmdline); + /* [env] is checked for null bytes at construction time, see unix.ml */ + exefile = search_exe_in_path(String_val(cmd)); if (env != Val_int(0)) { envp = String_val(Field(env, 0)); diff --git a/otherlibs/win32unix/sleep.c b/otherlibs/win32unix/sleep.c index 6d630d2057..650c6d670f 100644 --- a/otherlibs/win32unix/sleep.c +++ b/otherlibs/win32unix/sleep.c @@ -19,7 +19,7 @@ CAMLprim value unix_sleep(t) value t; { enter_blocking_section(); - Sleep(Int_val(t) * 1000); + Sleep(Double_val(t) * 1e3); leave_blocking_section(); return Val_unit; } diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml index b74f063e83..6b20715bfe 100644 --- a/otherlibs/win32unix/unix.ml +++ b/otherlibs/win32unix/unix.ml @@ -429,7 +429,8 @@ external gmtime : float -> tm = "unix_gmtime" external localtime : float -> tm = "unix_localtime" external mktime : tm -> float * tm = "unix_mktime" let alarm n = invalid_arg "Unix.alarm not implemented" -external sleep : int -> unit = "unix_sleep" +external sleepf : float -> unit = "unix_sleep" +let sleep n = sleepf (float n) external times: unit -> process_times = "unix_times" external utimes : string -> float -> float -> unit = "unix_utimes" @@ -813,12 +814,18 @@ let make_cmdline args = else f in String.concat " " (List.map maybe_quote (Array.to_list args)) +let make_process_env env = + Array.iter + (fun s -> if String.contains s '\000' then raise(Unix_error(EINVAL, "", s))) + env; + String.concat "\000" (Array.to_list env) ^ "\000" + let create_process prog args fd1 fd2 fd3 = win_create_process prog (make_cmdline args) None fd1 fd2 fd3 let create_process_env prog args env fd1 fd2 fd3 = win_create_process prog (make_cmdline args) - (Some(String.concat "\000" (Array.to_list env) ^ "\000")) + (Some(make_process_env env)) fd1 fd2 fd3 external system: string -> process_status = "win_system" @@ -877,7 +884,7 @@ let open_process_full cmd env = let inchan = in_channel_of_descr in_read in let outchan = out_channel_of_descr out_write in let errchan = in_channel_of_descr err_read in - open_proc cmd (Some(String.concat "\000" (Array.to_list env) ^ "\000")) + open_proc cmd (Some(make_process_env env)) (Process_full(inchan, outchan, errchan)) out_read in_write err_write; close out_read; close in_write; close err_write; diff --git a/otherlibs/win32unix/unixsupport.h b/otherlibs/win32unix/unixsupport.h index 9ce0fc997b..d6b796daa4 100644 --- a/otherlibs/win32unix/unixsupport.h +++ b/otherlibs/win32unix/unixsupport.h @@ -61,7 +61,7 @@ extern void unix_error (int errcode, char * cmdname, value arg); extern void uerror (char * cmdname, value arg); extern void caml_unix_check_path(value path, char * cmdname); extern value unix_freeze_buffer (value); -extern char ** cstringvect(value arg); +extern char ** cstringvect(value arg, char * cmdname); /* Information stored in flags_fd, describing more precisely the socket * and its status. The whole flags_fd is initialized to 0. diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli index a0d6361623..4b5fa46517 100644 --- a/parsing/asttypes.mli +++ b/parsing/asttypes.mli @@ -25,6 +25,7 @@ type rec_flag = Nonrecursive | Recursive type direction_flag = Upto | Downto +(* Order matters, used in polymorphic comparison *) type private_flag = Private | Public type mutable_flag = Immutable | Mutable diff --git a/parsing/lexer.mll b/parsing/lexer.mll index 7957a3b2a4..de331e328b 100644 --- a/parsing/lexer.mll +++ b/parsing/lexer.mll @@ -189,20 +189,6 @@ let cvt_nativeint_literal s = Nativeint.neg (Nativeint.of_string ("-" ^ String.sub s 0 (String.length s - 1))) -(* Remove underscores from float literals *) - -let remove_underscores s = - let l = String.length s in - let b = Bytes.create l in - let rec remove src dst = - if src >= l then - if dst >= l then s else Bytes.sub_string b 0 dst - else - match s.[src] with - '_' -> remove (src + 1) dst - | c -> Bytes.set b dst c; remove (src + 1) (dst + 1) - in remove 0 0 - (* recover the name from a LABEL or OPTLABEL token *) let get_label_name lexbuf = @@ -313,6 +299,11 @@ let float_literal = ['0'-'9'] ['0'-'9' '_']* ('.' ['0'-'9' '_']* )? (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? +let hex_float_literal = + '0' ['x' 'X'] + ['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']* + ('.' ['0'-'9' 'A'-'F' 'a'-'f' '_']*)? + (['p' 'P'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? rule token = parse | "\\" newline { @@ -356,8 +347,8 @@ rule token = parse with Failure _ -> raise (Error(Literal_overflow "int", Location.curr lexbuf)) } - | float_literal - { FLOAT (remove_underscores(Lexing.lexeme lexbuf)) } + | float_literal | hex_float_literal + { FLOAT (Lexing.lexeme lexbuf) } | int_literal "l" { try INT32 (cvt_int32_literal (Lexing.lexeme lexbuf)) @@ -373,7 +364,7 @@ rule token = parse NATIVEINT (cvt_nativeint_literal (Lexing.lexeme lexbuf)) with Failure _ -> raise (Error(Literal_overflow "nativeint", Location.curr lexbuf)) } - | (float_literal | int_literal) identchar+ + | (float_literal | hex_float_literal | int_literal) identchar+ { raise (Error(Invalid_literal (Lexing.lexeme lexbuf), Location.curr lexbuf)) } | "\"" diff --git a/stdlib/arg.ml b/stdlib/arg.ml index d8f5ff5e27..b9a7c9a27f 100644 --- a/stdlib/arg.ml +++ b/stdlib/arg.ml @@ -55,6 +55,12 @@ let rec assoc3 x l = | _ :: t -> assoc3 x t ;; +let split s = + let i = String.index s '=' in + let len = String.length s in + String.sub s 0 i, String.sub s (i+1) (len-(i+1)) +;; + let make_symlist prefix sep suffix l = match l with | [] -> "<none>" @@ -142,73 +148,93 @@ let parse_argv_dynamic ?(current=current) argv speclist anonfun errmsg = while !current < l do let s = argv.(!current) in if String.length s >= 1 && s.[0] = '-' then begin - let action = - try assoc3 s !speclist - with Not_found -> stop (Unknown s) + let action, follow = + try assoc3 s !speclist, None + with Not_found -> + try + let keyword, arg = split s in + assoc3 keyword !speclist, Some arg + with Not_found -> stop (Unknown s) + in + let no_arg () = + match follow with + | None -> () + | Some arg -> stop (Wrong (s, arg, "no argument")) in + let get_arg () = + match follow with + | None -> + if !current + 1 < l then argv.(!current + 1) + else stop (Missing s) + | Some arg -> arg + in + let consume_arg () = + match follow with + | None -> incr current + | Some _ -> () in begin try let rec treat_action = function | Unit f -> f (); - | Bool f when !current + 1 < l -> - let arg = argv.(!current + 1) in + | Bool f -> + let arg = get_arg () in begin match bool_of_string_opt arg with | None -> raise (Stop (Wrong (s, arg, "a boolean"))) | Some s -> f s end; - incr current; - | Set r -> r := true; - | Clear r -> r := false; - | String f when !current + 1 < l -> - f argv.(!current + 1); - incr current; - | Symbol (symb, f) when !current + 1 < l -> - let arg = argv.(!current + 1) in + consume_arg (); + | Set r -> no_arg (); r := true; + | Clear r -> no_arg (); r := false; + | String f -> + let arg = get_arg () in + f arg; + consume_arg (); + | Symbol (symb, f) -> + let arg = get_arg () in if List.mem arg symb then begin - f argv.(!current + 1); - incr current; + f arg; + consume_arg (); end else begin raise (Stop (Wrong (s, arg, "one of: " ^ (make_symlist "" " " "" symb)))) end - | Set_string r when !current + 1 < l -> - r := argv.(!current + 1); - incr current; - | Int f when !current + 1 < l -> - let arg = argv.(!current + 1) in + | Set_string r -> + r := get_arg (); + consume_arg (); + | Int f -> + let arg = get_arg () in begin match int_of_string_opt arg with | None -> raise (Stop (Wrong (s, arg, "an integer"))) | Some x -> f x end; - incr current; - | Set_int r when !current + 1 < l -> - let arg = argv.(!current + 1) in + consume_arg (); + | Set_int r -> + let arg = get_arg () in begin match int_of_string_opt arg with | None -> raise (Stop (Wrong (s, arg, "an integer"))) | Some x -> r := x end; - incr current; - | Float f when !current + 1 < l -> - let arg = argv.(!current + 1) in + consume_arg (); + | Float f -> + let arg = get_arg () in begin match float_of_string_opt arg with | None -> raise (Stop (Wrong (s, arg, "a float"))) | Some x -> f x end; - incr current; - | Set_float r when !current + 1 < l -> - let arg = argv.(!current + 1) in + consume_arg (); + | Set_float r -> + let arg = get_arg () in begin match float_of_string_opt arg with | None -> raise (Stop (Wrong (s, arg, "a float"))) | Some x -> r := x end; - incr current; + consume_arg (); | Tuple specs -> List.iter treat_action specs; | Rest f -> while !current < l - 1 do f argv.(!current + 1); - incr current; + consume_arg (); done; - | _ -> raise (Stop (Missing s)) in treat_action action with Bad m -> stop (Message m); diff --git a/stdlib/arg.mli b/stdlib/arg.mli index 0999edf5f3..71af638161 100644 --- a/stdlib/arg.mli +++ b/stdlib/arg.mli @@ -25,7 +25,8 @@ [Unit], [Set] and [Clear] keywords take no argument. A [Rest] keyword takes the remaining of the command line as arguments. Every other keyword takes the following word on the command line - as argument. + as argument. For compatibility with GNU getopt_long, [keyword=arg] + is also allowed. Arguments not preceded by a keyword are called anonymous arguments. Examples ([cmd] is assumed to be the command name): diff --git a/stdlib/camlinternalFormat.ml b/stdlib/camlinternalFormat.ml index 8d9f8d3450..ae0e133655 100644 --- a/stdlib/camlinternalFormat.ml +++ b/stdlib/camlinternalFormat.ml @@ -214,7 +214,10 @@ type precision_ebb = Precision_EBB : ('a, 'b) precision -> precision_ebb (* Constants *) (* Default precision for float printing. *) -let default_float_precision = 6 +let default_float_precision = -6 + (* For %h and %H formats, a negative precision means "as many digits as + necessary". For the other FP formats, we take the absolute value + of the precision, hence 6 digits by default. *) (******************************************************************************) (* Externals *) @@ -229,6 +232,8 @@ external format_nativeint: string -> nativeint -> string = "caml_nativeint_format" external format_int64: string -> int64 -> string = "caml_int64_format" +external hexstring_of_float: float -> int -> char -> string + = "caml_hexstring_of_float" (******************************************************************************) (* Tools to pretty-print formats *) @@ -283,6 +288,8 @@ let char_of_fconv fconv = match fconv with | Float_f | Float_pf | Float_sf -> 'f' | Float_e | Float_pe | Float_se -> 'e' | Float_E | Float_pE | Float_sE -> 'E' | Float_g | Float_pg | Float_sg -> 'g' | Float_G | Float_pG | Float_sG -> 'G' | Float_F -> 'F' + | Float_h | Float_ph | Float_sh -> 'h' | Float_H | Float_pH | Float_sH -> 'H' + (* Convert a scanning counter to char. *) let char_of_counter counter = match counter with @@ -424,11 +431,14 @@ let bprint_altint_fmt buf ign_flag iconv pad prec c = (* Print the optionnal '+' associated to a float conversion. *) let bprint_fconv_flag buf fconv = match fconv with - | Float_pf | Float_pe | Float_pE | Float_pg | Float_pG -> + | Float_pf | Float_pe | Float_pE + | Float_pg | Float_pG | Float_ph | Float_pH -> buffer_add_char buf '+' - | Float_sf | Float_se | Float_sE | Float_sg | Float_sG -> + | Float_sf | Float_se | Float_sE + | Float_sg | Float_sG | Float_sh | Float_sH -> buffer_add_char buf ' ' - | Float_f | Float_e | Float_E | Float_g | Float_G | Float_F -> + | Float_f | Float_e | Float_E + | Float_g | Float_G | Float_F | Float_h | Float_H -> () (* Print a complete float format in a buffer (ex: "%+*.3f"). *) @@ -1409,22 +1419,34 @@ let convert_int64 iconv n = format_int64 (format_of_iconvL iconv) n (* Convert a float to string. *) (* Fix special case of "OCaml float format". *) let convert_float fconv prec x = - let prec = abs prec in - let str = format_float (format_of_fconv fconv prec) x in - if fconv <> Float_F then str else - let len = String.length str in - let rec is_valid i = - if i = len then false else - match str.[i] with - | '.' | 'e' | 'E' -> true - | _ -> is_valid (i + 1) - in - match classify_float x with - | FP_normal | FP_subnormal | FP_zero -> - if is_valid 0 then str else str ^ "." - | FP_infinite -> - if x < 0.0 then "neg_infinity" else "infinity" - | FP_nan -> "nan" + match fconv with + | Float_h | Float_ph | Float_sh | Float_H | Float_pH | Float_sH -> + let sign = + match fconv with + | Float_ph | Float_pH -> '+' + | Float_sh | Float_sH -> ' ' + | _ -> '-' in + let str = hexstring_of_float x prec sign in + begin match fconv with + | Float_H | Float_pH | Float_sH -> String.uppercase_ascii str + | _ -> str + end + | _ -> + let str = format_float (format_of_fconv fconv prec) x in + if fconv <> Float_F then str else + let len = String.length str in + let rec is_valid i = + if i = len then false else + match str.[i] with + | '.' | 'e' | 'E' -> true + | _ -> is_valid (i + 1) + in + match classify_float x with + | FP_normal | FP_subnormal | FP_zero -> + if is_valid 0 then str else str ^ "." + | FP_infinite -> + if x < 0.0 then "neg_infinity" else "infinity" + | FP_nan -> "nan" (* Convert a char to a string according to the OCaml lexical convention. *) let format_caml_char c = @@ -2412,7 +2434,7 @@ let fmt_ebb_of_string ?legacy_behavior str = let Padprec_fmt_EBB (pad', prec', fmt_rest') = make_padprec_fmt_ebb (get_int_pad ()) (get_prec ()) fmt_rest in Fmt_EBB (Int64 (iconv, pad', prec', fmt_rest')) - | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> + | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' | 'h' | 'H' -> let fconv = compute_float_conv pct_ind str_ind (get_plus ()) (get_space ()) symb in let Fmt_EBB fmt_rest = parse str_ind end_ind in @@ -2878,6 +2900,12 @@ let fmt_ebb_of_string ?legacy_behavior str = | false, false, 'G' -> Float_G | false, true, 'G' -> Float_sG | true, false, 'G' -> Float_pG + | false, false, 'h' -> Float_h + | false, true, 'h' -> Float_sh + | true, false, 'h' -> Float_ph + | false, false, 'H' -> Float_H + | false, true, 'H' -> Float_sH + | true, false, 'H' -> Float_pH | false, false, 'F' -> Float_F | true, true, _ -> if legacy_behavior then diff --git a/stdlib/camlinternalFormatBasics.ml b/stdlib/camlinternalFormatBasics.ml index 60a74524ec..837b2bd870 100644 --- a/stdlib/camlinternalFormatBasics.ml +++ b/stdlib/camlinternalFormatBasics.ml @@ -36,6 +36,8 @@ type float_conv = | Float_g | Float_pg | Float_sg (* %g | %+g | % g *) | Float_G | Float_pG | Float_sG (* %G | %+G | % G *) | Float_F (* %F *) + | Float_h | Float_ph | Float_sh (* %h | %+h | % h *) + | Float_H | Float_pH | Float_sH (* %H | %+H | % H *) (***) diff --git a/stdlib/camlinternalFormatBasics.mli b/stdlib/camlinternalFormatBasics.mli index ee0235661b..817f4410c5 100644 --- a/stdlib/camlinternalFormatBasics.mli +++ b/stdlib/camlinternalFormatBasics.mli @@ -23,6 +23,7 @@ type float_conv = | Float_f | Float_pf | Float_sf | Float_e | Float_pe | Float_se | Float_E | Float_pE | Float_sE | Float_g | Float_pg | Float_sg | Float_G | Float_pG | Float_sG | Float_F + | Float_h | Float_ph | Float_sh | Float_H | Float_pH | Float_sH type char_set = string diff --git a/stdlib/list.mli b/stdlib/list.mli index 77cf5d5db6..e604a7f128 100644 --- a/stdlib/list.mli +++ b/stdlib/list.mli @@ -50,9 +50,8 @@ val rev : 'a list -> 'a list (** List reversal. *) val append : 'a list -> 'a list -> 'a list -(** Catenate two lists. Same function as the infix operator [@]. - Not tail-recursive (length of the first argument). The [@] - operator is not tail-recursive either. *) +(** Concatenate two lists. Same as the infix operator [@]. + Not tail-recursive (length of the first argument). *) val rev_append : 'a list -> 'a list -> 'a list (** [List.rev_append l1 l2] reverses [l1] and concatenates it to [l2]. diff --git a/stdlib/map.ml b/stdlib/map.ml index 7d65bc6bc9..fd05e30a88 100644 --- a/stdlib/map.ml +++ b/stdlib/map.ml @@ -103,14 +103,16 @@ module Make(Ord: OrderedType) = struct let rec add x data = function Empty -> Node(Empty, x, data, Empty, 1) - | Node(l, v, d, r, h) -> + | Node(l, v, d, r, h) as m -> let c = Ord.compare x v in if c = 0 then - Node(l, x, data, r, h) + if d == data then m else Node(l, x, data, r, h) else if c < 0 then - bal (add x data l) v d r + let ll = add x data l in + if l == ll then m else bal ll v d r else - bal l v d (add x data r) + let rr = add x data r in + if r == rr then m else bal l v d rr let rec find x = function Empty -> @@ -153,14 +155,13 @@ module Make(Ord: OrderedType) = struct let rec remove x = function Empty -> Empty - | Node(l, v, d, r, h) -> + | (Node(l, v, d, r, h) as t) -> let c = Ord.compare x v in - if c = 0 then - merge l r + if c = 0 then merge l r else if c < 0 then - bal (remove x l) v d r + let ll = remove x l in if l == ll then t else bal ll v d r else - bal l v d (remove x r) + let rr = remove x r in if r == rr then t else bal l v d rr let rec iter f = function Empty -> () @@ -271,12 +272,13 @@ module Make(Ord: OrderedType) = struct let rec filter p = function Empty -> Empty - | Node(l, v, d, r, _) -> + | Node(l, v, d, r, _) as t -> (* call [p] in the expected left-to-right order *) let l' = filter p l in let pvd = p v d in let r' = filter p r in - if pvd then join l' v d r' else concat l' r' + if pvd then if l==l' && r==r' then t else join l' v d r' + else concat l' r' let rec partition p = function Empty -> (Empty, Empty) diff --git a/stdlib/map.mli b/stdlib/map.mli index abf4531618..013495bfac 100644 --- a/stdlib/map.mli +++ b/stdlib/map.mli @@ -77,7 +77,11 @@ module type S = val add: key -> 'a -> 'a t -> 'a t (** [add x y m] returns a map containing the same bindings as [m], plus a binding of [x] to [y]. If [x] was already bound - in [m], its previous binding disappears. *) + in [m] to a value that is physically equal to [y], + [m] is returned unchanged (the result of the function is + then physically equal to [m]). Otherwise, the previous binding + of [x] in [m] disappears. + @before 4.03 Physical equality was not ensured. *) val singleton: key -> 'a -> 'a t (** [singleton x y] returns the one-element map that contains a binding [y] @@ -87,7 +91,10 @@ module type S = val remove: key -> 'a t -> 'a t (** [remove x m] returns a map containing the same bindings as - [m], except for [x] which is unbound in the returned map. *) + [m], except for [x] which is unbound in the returned map. + If [x] was not in [m], [m] is returned unchanged + (the result of the function is then physically equal to [m]). + @before 4.03 Physical equality was not ensured. *) val merge: (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t @@ -132,8 +139,11 @@ module type S = val filter: (key -> 'a -> bool) -> 'a t -> 'a t (** [filter p m] returns the map with all the bindings in [m] - that satisfy predicate [p]. + that satisfy predicate [p]. If [p] satisfies every binding in [m], + [m] is returned unchanged (the result of the function is then + physically equal to [m]) @since 3.12.0 + @before 4.03 Physical equality was not ensured. *) val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t diff --git a/stdlib/obj.ml b/stdlib/obj.ml index 5cb970b8e4..76a4e67b54 100644 --- a/stdlib/obj.ml +++ b/stdlib/obj.ml @@ -60,7 +60,7 @@ let int_tag = 1000 let out_of_heap_tag = 1001 let unaligned_tag = 1002 -let extension_slot x = +let extension_constructor x = let x = repr x in let slot = if (is_block x) && (tag x) <> object_tag && (size x) >= 1 then field x 0 @@ -68,24 +68,13 @@ let extension_slot x = in let name = if (is_block slot) && (tag slot) = object_tag then field slot 0 - else raise Not_found + else invalid_arg "Obj.extension_constructor" in - if (tag name) = string_tag then slot - else raise Not_found + if (tag name) = string_tag then (obj slot : extension_constructor) + else invalid_arg "Obj.extension_constructor" -let extension_name x = - try - let slot = extension_slot x in - (obj (field slot 0) : string) - with Not_found -> invalid_arg "Obj.extension_name" +let extension_name (slot : extension_constructor) = + (obj (field (repr slot) 0) : string) -let extension_id x = - try - let slot = extension_slot x in - (obj (field slot 1) : int) - with Not_found -> invalid_arg "Obj.extension_id" - -let extension_slot x = - try - extension_slot x - with Not_found -> invalid_arg "Obj.extension_slot" +let extension_id (slot : extension_constructor) = + (obj (field (repr slot) 1) : int) diff --git a/stdlib/obj.mli b/stdlib/obj.mli index 6d06312b4d..fecac323ea 100644 --- a/stdlib/obj.mli +++ b/stdlib/obj.mli @@ -57,9 +57,9 @@ val int_tag : int val out_of_heap_tag : int val unaligned_tag : int (* should never happen @since 3.11.0 *) -val extension_name : 'a -> string -val extension_id : 'a -> int -val extension_slot : 'a -> t +val extension_constructor : 'a -> extension_constructor +val extension_name : extension_constructor -> string +val extension_id : extension_constructor -> int (** The following two functions are deprecated. Use module {!Marshal} instead. *) diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli index 553253a16b..16f551ce0d 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -597,7 +597,7 @@ external snd : 'a * 'b -> 'b = "%field1" *) val ( @ ) : 'a list -> 'a list -> 'a list -(** List concatenation. *) +(** List concatenation. Not tail-recursive (length of the first argument). *) diff --git a/stdlib/printf.mli b/stdlib/printf.mli index db3f0a9bd4..70d50ea285 100644 --- a/stdlib/printf.mli +++ b/stdlib/printf.mli @@ -55,6 +55,9 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a in the style [d.ddd e+-dd] (mantissa and exponent). - [g] or [G]: convert a floating-point argument to decimal notation, in style [f] or [e], [E] (whichever is more compact). + - [h] or [H]: convert a floating-point argument to hexadecimal notation, + in the style [0xh.hhhh e+-dd] (hexadecimal mantissa, exponent in + decimal and denotes a power of 2). - [B]: convert a boolean argument to the string [true] or [false] - [b]: convert a boolean argument (deprecated; do not use in new programs). diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml index 3abcf47c1c..b81142efd4 100644 --- a/stdlib/scanf.ml +++ b/stdlib/scanf.ml @@ -475,6 +475,10 @@ let bad_float () = bad_input "no dot or exponent part found in float token" ;; +let bad_hex_float () = + bad_input "not a valid float in hexadecimal notation" +;; + let character_mismatch_err c ci = Printf.sprintf "looking for %C, found %C" c ci ;; @@ -800,13 +804,71 @@ let scan_float width precision ib = scan_exp_part width ib, precision ;; -let scan_caml_float width precision ib = - let width = scan_optionally_signed_decimal_int width ib in - if width = 0 then bad_float () else - let c = Scanning.peek_char ib in - if Scanning.eof ib then bad_float () else - match c with - | '.' -> +let check_case_insensitive_string width ib error str = + let lowercase c = match c with + | 'A' .. 'Z' -> char_of_int (int_of_char c - int_of_char 'A' + int_of_char 'a') + | _ -> c in + let len = String.length str in + let width = ref width in + for i = 0 to len - 1 do + let c = Scanning.peek_char ib in + if lowercase c <> lowercase str.[i] then error (); + if !width = 0 then error (); + width := Scanning.store_char !width ib c; + done; + !width +;; + +let scan_hex_float width precision ib = + if width = 0 || Scanning.end_of_input ib then bad_hex_float (); + let width = scan_sign width ib in + if width = 0 || Scanning.end_of_input ib then bad_hex_float (); + match Scanning.peek_char ib with + | '0' as c -> ( + let width = Scanning.store_char width ib c in + if width = 0 || Scanning.end_of_input ib then bad_hex_float (); + let width = check_case_insensitive_string width ib bad_hex_float "x" in + if width = 0 || Scanning.end_of_input ib then width else + let width = match Scanning.peek_char ib with + | '.' | 'p' | 'P' -> width + | _ -> scan_hexadecimal_int width ib in + if width = 0 || Scanning.end_of_input ib then width else + let width = match Scanning.peek_char ib with + | '.' as c -> ( + let width = Scanning.store_char width ib c in + if width = 0 || Scanning.end_of_input ib then width else + match Scanning.peek_char ib with + | 'p' | 'P' -> width + | _ -> + let precision = min width precision in + width - (precision - scan_hexadecimal_int precision ib) + ) + | _ -> width in + if width = 0 || Scanning.end_of_input ib then width else + match Scanning.peek_char ib with + | 'p' | 'P' as c -> + let width = Scanning.store_char width ib c in + if width = 0 || Scanning.end_of_input ib then bad_hex_float (); + scan_optionally_signed_decimal_int width ib + | _ -> width + ) + | 'n' | 'N' as c -> + let width = Scanning.store_char width ib c in + if width = 0 || Scanning.end_of_input ib then bad_hex_float (); + check_case_insensitive_string width ib bad_hex_float "an" + | 'i' | 'I' as c -> + let width = Scanning.store_char width ib c in + if width = 0 || Scanning.end_of_input ib then bad_hex_float (); + check_case_insensitive_string width ib bad_hex_float "nfinity" + | _ -> bad_hex_float () +;; + +let scan_caml_float_rest width precision ib = + if width = 0 || Scanning.end_of_input ib then bad_float (); + let width = scan_decimal_digits width ib in + if width = 0 || Scanning.end_of_input ib then bad_float (); + match Scanning.peek_char ib with + | '.' as c -> let width = Scanning.store_char width ib c in (* The effective width available for scanning the fractional part is the minimum of declared precision and width left. *) @@ -825,6 +887,50 @@ let scan_caml_float width precision ib = | _ -> bad_float () ;; +let scan_caml_float width precision ib = + if width = 0 || Scanning.end_of_input ib then bad_float (); + let width = scan_sign width ib in + if width = 0 || Scanning.end_of_input ib then bad_float (); + match Scanning.peek_char ib with + | '0' as c -> ( + let width = Scanning.store_char width ib c in + if width = 0 || Scanning.end_of_input ib then bad_float (); + match Scanning.peek_char ib with + | 'x' | 'X' as c -> ( + let width = Scanning.store_char width ib c in + if width = 0 || Scanning.end_of_input ib then bad_float (); + let width = scan_hexadecimal_int width ib in + if width = 0 || Scanning.end_of_input ib then bad_float (); + let width = match Scanning.peek_char ib with + | '.' as c -> ( + let width = Scanning.store_char width ib c in + if width = 0 || Scanning.end_of_input ib then width else + match Scanning.peek_char ib with + | 'p' | 'P' -> width + | _ -> + let precision = min width precision in + width - (precision - scan_hexadecimal_int precision ib) + ) + | 'p' | 'P' -> width + | _ -> bad_float () in + if width = 0 || Scanning.end_of_input ib then width else + match Scanning.peek_char ib with + | 'p' | 'P' as c -> + let width = Scanning.store_char width ib c in + if width = 0 || Scanning.end_of_input ib then bad_hex_float (); + scan_optionally_signed_decimal_int width ib + | _ -> width + ) + | _ -> + scan_caml_float_rest width precision ib + ) + | '1' .. '9' as c -> + let width = Scanning.store_char width ib c in + if width = 0 || Scanning.end_of_input ib then bad_float (); + scan_caml_float_rest width precision ib + | _ -> bad_float () +;; + (* Scan a regular string: stops when encountering a space, if no scanning indication has been given; otherwise, stops when encountering the characters in the scanning @@ -1223,7 +1329,9 @@ fun ib fmt readers -> match fmt with | Float_E | Float_pE | Float_sE | Float_g | Float_pg | Float_sg | Float_G | Float_pG | Float_sG), pad, prec, rest) -> pad_prec_scanf ib rest readers pad prec scan_float token_float - + | Float ((Float_h | Float_ph | Float_sh | Float_H | Float_pH | Float_sH), + pad, prec, rest) -> + pad_prec_scanf ib rest readers pad prec scan_hex_float token_float | Bool rest -> let _ = scan_bool ib in let b = token_bool ib in diff --git a/stdlib/scanf.mli b/stdlib/scanf.mli index 2b0d562873..3c5f390d45 100644 --- a/stdlib/scanf.mli +++ b/stdlib/scanf.mli @@ -312,6 +312,8 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner - [f], [e], [E], [g], [G]: reads an optionally signed floating-point number in decimal notation, in the style [dddd.ddd e/E+-dd]. + - [h], [H]: reads an optionally signed floating-point number + in hexadecimal notation. - [F]: reads a floating point number according to the lexical conventions of OCaml (hence the decimal point is mandatory if the exponent part is not mentioned). diff --git a/stdlib/stack.ml b/stdlib/stack.ml index 4db3d5b436..e65be5f35a 100644 --- a/stdlib/stack.ml +++ b/stdlib/stack.ml @@ -11,30 +11,30 @@ (* *) (***********************************************************************) -type 'a t = { mutable c : 'a list } +type 'a t = { mutable c : 'a list; mutable len : int; } exception Empty -let create () = { c = [] } +let create () = { c = []; len = 0; } -let clear s = s.c <- [] +let clear s = s.c <- []; s.len <- 0 -let copy s = { c = s.c } +let copy s = { c = s.c; len = s.len; } -let push x s = s.c <- x :: s.c +let push x s = s.c <- x :: s.c; s.len <- s.len + 1 let pop s = match s.c with - hd::tl -> s.c <- tl; hd + | hd::tl -> s.c <- tl; s.len <- s.len - 1; hd | [] -> raise Empty let top s = match s.c with - hd::_ -> hd + | hd::_ -> hd | [] -> raise Empty let is_empty s = (s.c = []) -let length s = List.length s.c +let length s = s.len let iter f s = List.iter f s.c diff --git a/stdlib/stack.mli b/stdlib/stack.mli index 9b468aa6cc..5874e648e4 100644 --- a/stdlib/stack.mli +++ b/stdlib/stack.mli @@ -47,7 +47,7 @@ val is_empty : 'a t -> bool (** Return [true] if the given stack is empty, [false] otherwise. *) val length : 'a t -> int -(** Return the number of elements in a stack. *) +(** Return the number of elements in a stack. Time complexity O(1) *) val iter : ('a -> unit) -> 'a t -> unit (** [iter f s] applies [f] in turn to all elements of [s], diff --git a/testsuite/tests/asmcomp/arith.cmm b/testsuite/tests/asmcomp/arith.cmm index e5965bc9d1..2d10318629 100644 --- a/testsuite/tests/asmcomp/arith.cmm +++ b/testsuite/tests/asmcomp/arith.cmm @@ -214,4 +214,5 @@ (floataset d 37 (-f f)) (floataset d 38 (absf f)) + (addraset r 116 (mulh x y)) ))))))) diff --git a/testsuite/tests/asmcomp/lexcmm.mll b/testsuite/tests/asmcomp/lexcmm.mll index 473f3d9e0b..7586189f09 100644 --- a/testsuite/tests/asmcomp/lexcmm.mll +++ b/testsuite/tests/asmcomp/lexcmm.mll @@ -55,6 +55,7 @@ let keyword_table = "let", LET; "load", LOAD; "mod", MODI; + "mulh", MULH; "or", OR; "proj", PROJ; "raise", RAISE Lambda.Raise_regular; diff --git a/testsuite/tests/asmcomp/mainarith.c b/testsuite/tests/asmcomp/mainarith.c index 4af44b857b..cb2ef3f08e 100644 --- a/testsuite/tests/asmcomp/mainarith.c +++ b/testsuite/tests/asmcomp/mainarith.c @@ -61,6 +61,7 @@ double F, G; extern void call_gen_code(void (*)(void)); extern void testarith(void); +static intnat mulhs(intnat x, intnat y); void do_test(void) { @@ -252,29 +253,55 @@ void do_test(void) FLOATTEST(D[37], - F); FLOATTEST(D[38], fabs(F)); + + INTTEST(R[116], mulhs(X, Y)); } -#ifdef __i386__ -#ifdef __FreeBSD__ -#include <floatingpoint.h> -#endif -#endif +/* Multiply-high signed. Hacker's Delight section 8.2 */ + +#define HALFSIZE (4 * sizeof(intnat)) +#define HALFMASK (((intnat)1 << HALFSIZE) - 1) -void init_ieee_floats(void) +static intnat mulhs(intnat u, intnat v) { -#ifdef __i386__ -#ifdef __FreeBSD__ - fpsetmask(0); -#endif + uintnat u0, v0, w0; + intnat u1, v1, w1, w2, t; + u0 = u & HALFMASK; u1 = u >> HALFSIZE; + v0 = v & HALFMASK; v1 = v >> HALFSIZE; + w0 = u0*v0; + t = u1*v0 + (w0 >> HALFSIZE); + w1 = t & HALFMASK; + w2 = t >> HALFSIZE; + w1 = u0*v1 + w1; + return u1*v1 + w2 + (w1 >> HALFSIZE); +} + +/* A simple linear congruential PRNG */ + +#ifdef ARCH_SIXTYFOUR +#define RAND_A 6364136223846793005ULL +#define RAND_C 1442695040888963407ULL +#else +#define RAND_A 214013U +#define RAND_C 2531011U #endif + +static intnat rnd(void) +{ + static uintnat seed = 0; + seed = seed * RAND_A + RAND_C; + return (intnat) seed; } +/* Test harness */ + +#define NUM_RANDOM_ITERATIONS 1000000 + int main(int argc, char **argv) { + int i; double weird[4]; - init_ieee_floats(); - if (argc >= 5) { X = atoi(argv[1]); Y = atoi(argv[2]); @@ -283,12 +310,14 @@ int main(int argc, char **argv) do_test(); return 0; } + printf("Testing -2...2\n"); for(Y = -2; Y <= 2; Y++) { for (X = -2; X <= 2; X++) { F = X; G = Y; do_test(); } } if (!(argc >= 2 && strcmp(argv[1], "noinf"))) { + printf("Testing special FP values\n"); weird[0] = 0.0; weird[1] = 1.0 / weird[0]; /* +infty */ weird[2] = -1.0 / weird[0]; /* -infty */ @@ -299,13 +328,13 @@ int main(int argc, char **argv) } } } - while(1) { - X = (rand() & 0x1FFFFFFF) - 0x10000000; - Y = (rand() & 0x1FFFFFFF) - 0x10000000; + printf("Testing %d random values\n", NUM_RANDOM_ITERATIONS); + for (i = 0; i < NUM_RANDOM_ITERATIONS; i++) { + X = rnd(); + Y = rnd(); F = X / 1e3; G = Y / 1e3; do_test(); - printf("."); fflush(stdout); } return 0; } diff --git a/testsuite/tests/asmcomp/parsecmm.mly b/testsuite/tests/asmcomp/parsecmm.mly index a987ed08e7..553ab66bc8 100644 --- a/testsuite/tests/asmcomp/parsecmm.mly +++ b/testsuite/tests/asmcomp/parsecmm.mly @@ -102,6 +102,7 @@ let access_array base numelt size = %token LTI %token MODI %token MULF +%token MULH %token MULI %token NEA %token NEF @@ -289,6 +290,7 @@ binaryop: | GTF { Ccmpf Cgt } | GEF { Ccmpf Cge } | CHECKBOUND { Ccheckbound Debuginfo.none } + | MULH { Cmulhi } ; sequence: expr sequence { Csequence($1, $2) } diff --git a/testsuite/tests/asmcomp/s390x.S b/testsuite/tests/asmcomp/s390x.S new file mode 100644 index 0000000000..eb5bd23fe0 --- /dev/null +++ b/testsuite/tests/asmcomp/s390x.S @@ -0,0 +1,64 @@ +#define ALIGN 8 + +#define CALL_GEN_CODE call_gen_code +#define CAML_C_CALL caml_c_call +#define CAML_NEGF_MASK caml_negf_mask +#define CAML_ABSF_MASK caml_absf_mask + + .section ".text" + + .globl CALL_GEN_CODE + .type CALL_GEN_CODE, @function + .align ALIGN +CALL_GEN_CODE: + /* Stack space */ + lay %r15, -144(%r15) + /* Save registers */ + stmg %r6,%r14, 0(%r15) + std %f8, 72(%r15) + std %f9, 80(%r15) + std %f10, 88(%r15) + std %f11, 96(%r15) + std %f12, 104(%r15) + std %f13, 112(%r15) + std %f14, 120(%r15) + std %f15, 128(%r15) + /* Shuffle args */ + lgr %r1, %r2 + lgr %r2, %r3 + lgr %r3, %r4 + lgr %r4, %r5 + /* Function call */ + basr %r14, %r1 + /* Restore registers */ + lmg %r6,%r14, 0(%r15) + ld %f8, 72(%r15) + ld %f9, 80(%r15) + ld %f10, 88(%r15) + ld %f11, 96(%r15) + ld %f12, 104(%r15) + ld %f13, 112(%r15) + ld %f14, 120(%r15) + ld %f15, 128(%r15) + /* Return */ + lay %r15, 144(%r15) + br %r14 + + .globl CAML_C_CALL + .type CAML_C_CALL, @function + .align ALIGN +CAML_C_CALL: + br %r7 + + .section ".rodata" + + .global CAML_NEGF_MASK + .align ALIGN +CAML_NEGF_MASK: + .quad 0x8000000000000000, 0 + .global CAML_ABSF_MASK + .align ALIGN +CAML_ABSF_MASK: + .quad 0x7FFFFFFFFFFFFFFF, 0 + + .comm young_limit, 8 diff --git a/testsuite/tests/extension-constructor/Makefile b/testsuite/tests/extension-constructor/Makefile new file mode 100644 index 0000000000..299656b246 --- /dev/null +++ b/testsuite/tests/extension-constructor/Makefile @@ -0,0 +1,15 @@ +######################################################################### +# # +# OCaml # +# # +# Xavier Clerc, SED, INRIA Rocquencourt # +# # +# Copyright 2010 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.several +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/extension-constructor/test.ml b/testsuite/tests/extension-constructor/test.ml new file mode 100644 index 0000000000..781e72dd54 --- /dev/null +++ b/testsuite/tests/extension-constructor/test.ml @@ -0,0 +1,29 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +type t = .. + +module M = struct + type t += A + type t += B of int +end + +type t += C +type t += D of int * string + +let () = + assert (Obj.extension_constructor M.A == [%extension_constructor M.A]); + assert (Obj.extension_constructor (M.B 42) == [%extension_constructor M.B]); + assert (Obj.extension_constructor C == [%extension_constructor C ]); + assert (Obj.extension_constructor (D (42, "")) == [%extension_constructor D ]) + +let () = print_endline "OK" diff --git a/testsuite/tests/extension-constructor/test.reference b/testsuite/tests/extension-constructor/test.reference new file mode 100644 index 0000000000..d86bac9de5 --- /dev/null +++ b/testsuite/tests/extension-constructor/test.reference @@ -0,0 +1 @@ +OK diff --git a/testsuite/tests/lib-arg/Makefile b/testsuite/tests/lib-arg/Makefile new file mode 100644 index 0000000000..c833913b8e --- /dev/null +++ b/testsuite/tests/lib-arg/Makefile @@ -0,0 +1,17 @@ +######################################################################### +# # +# OCaml # +# # +# Damien Doligez, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2013 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +BASEDIR=../.. +MAIN_MODULE=testarg + +include $(BASEDIR)/makefiles/Makefile.one +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/lib-arg/testarg.ml b/testsuite/tests/lib-arg/testarg.ml new file mode 100644 index 0000000000..1994ba882a --- /dev/null +++ b/testsuite/tests/lib-arg/testarg.ml @@ -0,0 +1,123 @@ +let current = ref 0;; + +let accum = ref [];; + +let record fmt (* args *) = + Printf.kprintf (fun s -> accum := s :: !accum) fmt +;; + +let f_unit () = record "unit()";; +let f_bool b = record "bool(%b)" b;; +let r_set = ref false;; +let r_clear = ref true;; +let f_string s = record "string(%s)" s;; +let r_string = ref "";; +let f_int i = record "int(%d)" i;; +let r_int = ref 0;; +let f_float f = record "float(%g)" f;; +let r_float = ref 0.0;; +let f_symbol s = record "symbol(%s)" s;; +let f_rest s = record "rest(%s)" s;; +let f_anon s = record "anon(%s)" s;; + +let spec = Arg.[ + "-u", Unit f_unit, "Unit (0)"; + "-b", Bool f_bool, "Bool (1)"; + "-s", Set r_set, "Set (0)"; + "-c", Clear r_clear, "Clear (0)"; + "-str", String f_string, "String (1)"; + "-sstr", Set_string r_string, "Set_string (1)"; + "-i", Int f_int, "Int (1)"; + "-si", Set_int r_int, "Set_int (1)"; + "-f", Float f_float, "Float (1)"; + "-sf", Set_float r_float, "Set_float (1)"; + "-t", Tuple [Bool f_bool; String f_string; Int f_int], "Tuple (3)"; + "-sym", Symbol (["a"; "b"; "c"], f_symbol), "Symbol (1)"; + "-rest", Rest f_rest, "Rest (*)"; +];; + +let args1 = [| + "prog"; + "anon1"; + "-u"; + "-b"; "true"; + "-s"; + "anon2"; + "-c"; + "-str"; "foo"; + "-sstr"; "bar"; + "-i"; "19"; + "-si"; "42"; + "-f"; "3.14"; + "-sf"; "2.72"; + "anon3"; + "-t"; "false"; "gee"; "1436"; + "-sym"; "c"; + "anon4"; + "-rest"; "r1"; "r2"; +|];; + +let args2 = [| + "prog"; + "anon1"; + "-u"; + "-b=true"; + "-s"; + "anon2"; + "-c"; + "-str=foo"; + "-sstr=bar"; + "-i=19"; + "-si=42"; + "-f=3.14"; + "-sf=2.72"; + "anon3"; + "-t"; "false"; "gee"; "1436"; + "-sym=c"; + "anon4"; + "-rest"; "r1"; "r2"; +|];; + +let error s = Printf.printf "error (%s)\n" s;; +let check r v msg = if !r <> v then error msg;; + +let test argv = + current := 0; + r_set := false; + r_clear := true; + r_string := ""; + r_int := 0; + r_float := 0.0; + accum := []; + Arg.parse_argv ~current argv spec f_anon "usage"; + let result = List.rev !accum in + let reference = [ + "anon(anon1)"; + "unit()"; + "bool(true)"; + "anon(anon2)"; + "string(foo)"; + "int(19)"; + "float(3.14)"; + "anon(anon3)"; + "bool(false)"; "string(gee)"; "int(1436)"; + "symbol(c)"; + "anon(anon4)"; + "rest(r1)"; "rest(r2)"; + ] + in + if result <> reference then begin + let f x y = + Printf.printf "%20s %c %-20s\n%!" x (if x = y then '=' else '#') y + in + List.iter2 f result reference; + end; + check r_set true "Set"; + check r_clear false "Clear"; + check r_string "bar" "Set_string"; + check r_int 42 "Set_int"; + check r_float 2.72 "Set_float"; +;; + +test args1;; +test args2;; diff --git a/testsuite/tests/lib-arg/testarg.reference b/testsuite/tests/lib-arg/testarg.reference new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/lib-arg/testarg.reference diff --git a/testsuite/tests/lib-format/tformat.ml b/testsuite/tests/lib-format/tformat.ml index 13c6094bd1..ad0f16cc73 100644 --- a/testsuite/tests/lib-format/tformat.ml +++ b/testsuite/tests/lib-format/tformat.ml @@ -252,6 +252,36 @@ try test (sprintf "%.3F" 0.0042 = "0.004"); *) + say "\nh\n%!"; + test (sprintf "%+h" (+0.) = "+0x0p+0"); + test (sprintf "%+h" (-0.) = "-0x0p+0"); + test (sprintf "%+h" (+1.) = "+0x1p+0"); + test (sprintf "%+h" (-1.) = "-0x1p+0"); + test (sprintf "%+h" (+1024.) = "+0x1p+10"); + test (sprintf "%+h" (-1024.) = "-0x1p+10"); + test (sprintf "%h" 0x123.456 = "0x1.23456p+8"); + test (sprintf "%h" 0x123456789ABCDE. = "0x1.23456789abcdep+52"); + test (sprintf "%h" epsilon_float = "0x1p-52"); + test (sprintf "%h" nan = "nan"); + test (sprintf "%h" infinity = "infinity"); + test (sprintf "%h" neg_infinity = "-infinity"); + test (sprintf "%h" (4. *. atan 1.) = "0x1.921fb54442d18p+1"); + + say "\nH\n%!"; + test (sprintf "%+H" (+0.) = "+0X0P+0"); + test (sprintf "%+H" (-0.) = "-0X0P+0"); + test (sprintf "%+H" (+1.) = "+0X1P+0"); + test (sprintf "%+H" (-1.) = "-0X1P+0"); + test (sprintf "%+H" (+1024.) = "+0X1P+10"); + test (sprintf "%+H" (-1024.) = "-0X1P+10"); + test (sprintf "%H" 0X123.456 = "0X1.23456P+8"); + test (sprintf "%H" 0X123456789ABCDE. = "0X1.23456789ABCDEP+52"); + test (sprintf "%H" epsilon_float = "0X1P-52"); + test (sprintf "%H" nan = "NAN"); + test (sprintf "%H" infinity = "INFINITY"); + test (sprintf "%H" neg_infinity = "-INFINITY"); + test (sprintf "%H" (4. *. atan 1.) = "0X1.921FB54442D18P+1"); + say "\ne\n%!"; test (sprintf "%e" (-42.42) =* "-4.242000e+01"); test (sprintf "%-15e" (-42.42) =* "-4.242000e+01 "); diff --git a/testsuite/tests/lib-format/tformat.reference b/testsuite/tests/lib-format/tformat.reference index cf2b241ce7..461fe9dada 100644 --- a/testsuite/tests/lib-format/tformat.reference +++ b/testsuite/tests/lib-format/tformat.reference @@ -30,62 +30,66 @@ f 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 F 119 120 121 122 123 124 125 +h + 126 127 128 129 130 131 132 133 134 135 136 137 138 +H + 139 140 141 142 143 144 145 146 147 148 149 150 151 e - 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 + 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 E - 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 + 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 B - 162 163 + 188 189 ld/li positive - 164 165 166 167 168 169 170 171 172 + 190 191 192 193 194 195 196 197 198 ld/li negative - 173 174 175 176 177 178 179 180 181 + 199 200 201 202 203 204 205 206 207 lu positive - 182 183 184 185 186 187 188 189 190 + 208 209 210 211 212 213 214 215 216 lu negative - 191 + 217 lx positive - 192 193 194 195 196 197 198 199 200 + 218 219 220 221 222 223 224 225 226 lx negative - 201 + 227 lX positive - 202 203 204 205 206 207 208 209 210 + 228 229 230 231 232 233 234 235 236 lx negative - 211 + 237 lo positive - 212 213 214 215 216 217 218 219 220 + 238 239 240 241 242 243 244 245 246 lo negative - 221 + 247 Ld/Li positive - 222 223 224 225 226 227 228 229 230 + 248 249 250 251 252 253 254 255 256 Ld/Li negative - 231 232 233 234 235 236 237 238 239 + 257 258 259 260 261 262 263 264 265 Lu positive - 240 241 242 243 244 245 246 247 248 + 266 267 268 269 270 271 272 273 274 Lu negative - 249 + 275 Lx positive - 250 251 252 253 254 255 256 257 258 + 276 277 278 279 280 281 282 283 284 Lx negative - 259 + 285 LX positive - 260 261 262 263 264 265 266 267 268 + 286 287 288 289 290 291 292 293 294 Lx negative - 269 + 295 Lo positive - 270 271 272 273 274 275 276 277 278 + 296 297 298 299 300 301 302 303 304 Lo negative - 279 + 305 a - 280 + 306 t - 281 + 307 {...%} - 282 + 308 (...%) - 283 + 309 ! % @ , and constants - 284 285 286 287 288 289 290 + 310 311 312 313 314 315 316 end of tests All tests succeeded. diff --git a/testsuite/tests/lib-printf/tprintf.ml b/testsuite/tests/lib-printf/tprintf.ml index cb4ee657b8..1535d0e37a 100644 --- a/testsuite/tests/lib-printf/tprintf.ml +++ b/testsuite/tests/lib-printf/tprintf.ml @@ -286,6 +286,36 @@ try test (sprintf "%.3F" 0.0042 = "0.004"); *) + printf "\nh\n%!"; + test (sprintf "%+h" (+0.) = "+0x0p+0"); + test (sprintf "%+h" (-0.) = "-0x0p+0"); + test (sprintf "%+h" (+1.) = "+0x1p+0"); + test (sprintf "%+h" (-1.) = "-0x1p+0"); + test (sprintf "%+h" (+1024.) = "+0x1p+10"); + test (sprintf "%+h" (-1024.) = "-0x1p+10"); + test (sprintf "%h" 0x123.456 = "0x1.23456p+8"); + test (sprintf "%h" 0x123456789ABCDE. = "0x1.23456789abcdep+52"); + test (sprintf "%h" epsilon_float = "0x1p-52"); + test (sprintf "%h" nan = "nan"); + test (sprintf "%h" infinity = "infinity"); + test (sprintf "%h" neg_infinity = "-infinity"); + test (sprintf "%h" (4. *. atan 1.) = "0x1.921fb54442d18p+1"); + + printf "\nH\n%!"; + test (sprintf "%+H" (+0.) = "+0X0P+0"); + test (sprintf "%+H" (-0.) = "-0X0P+0"); + test (sprintf "%+H" (+1.) = "+0X1P+0"); + test (sprintf "%+H" (-1.) = "-0X1P+0"); + test (sprintf "%+H" (+1024.) = "+0X1P+10"); + test (sprintf "%+H" (-1024.) = "-0X1P+10"); + test (sprintf "%H" 0X123.456 = "0X1.23456P+8"); + test (sprintf "%H" 0X123456789ABCDE. = "0X1.23456789ABCDEP+52"); + test (sprintf "%H" epsilon_float = "0X1P-52"); + test (sprintf "%H" nan = "NAN"); + test (sprintf "%H" infinity = "INFINITY"); + test (sprintf "%H" neg_infinity = "-INFINITY"); + test (sprintf "%H" (4. *. atan 1.) = "0X1.921FB54442D18P+1"); + printf "\ne\n%!"; test (sprintf "%e" (-42.42) =* "-4.242000e+01"); test (sprintf "%-15e" (-42.42) =* "-4.242000e+01 "); diff --git a/testsuite/tests/lib-printf/tprintf.reference b/testsuite/tests/lib-printf/tprintf.reference index 3a6c3f0dbc..de3dc1dbdd 100644 --- a/testsuite/tests/lib-printf/tprintf.reference +++ b/testsuite/tests/lib-printf/tprintf.reference @@ -30,62 +30,66 @@ f 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 F 85 86 87 88 89 90 91 +h + 92 93 94 95 96 97 98 99 100 101 102 103 104 +H + 105 106 107 108 109 110 111 112 113 114 115 116 117 e - 92 93 94 95 96 97 98 99 100 101 102 103 104 105 + 118 119 120 121 122 123 124 125 126 127 128 129 130 131 E - 106 107 108 109 110 111 112 113 114 115 116 117 118 119 + 132 133 134 135 136 137 138 139 140 141 142 143 144 145 B - 120 121 + 146 147 ld/li positive - 122 123 124 125 126 127 128 + 148 149 150 151 152 153 154 ld/li negative - 129 130 131 132 133 134 135 + 155 156 157 158 159 160 161 lu positive - 136 137 138 139 140 + 162 163 164 165 166 lu negative - 141 + 167 lx positive - 142 143 144 145 146 147 + 168 169 170 171 172 173 lx negative - 148 + 174 lX positive - 149 150 151 152 153 154 + 175 176 177 178 179 180 lx negative - 155 + 181 lo positive - 156 157 158 159 160 161 + 182 183 184 185 186 187 lo negative - 162 + 188 Ld/Li positive - 163 164 165 166 167 + 189 190 191 192 193 Ld/Li negative - 168 169 170 171 172 + 194 195 196 197 198 Lu positive - 173 174 175 176 177 + 199 200 201 202 203 Lu negative - 178 + 204 Lx positive - 179 180 181 182 183 184 + 205 206 207 208 209 210 Lx negative - 185 + 211 LX positive - 186 187 188 189 190 191 + 212 213 214 215 216 217 Lx negative - 192 + 218 Lo positive - 193 194 195 196 197 198 + 219 220 221 222 223 224 Lo negative - 199 + 225 a - 200 + 226 t - 201 + 227 {...%} - 202 + 228 (...%) - 203 + 229 ! % @ , and constants - 204 205 206 207 208 209 210 + 230 231 232 233 234 235 236 end of tests All tests succeeded. diff --git a/testsuite/tests/lib-scanf/tscanf.ml b/testsuite/tests/lib-scanf/tscanf.ml index a93637ec04..c19bb367a7 100644 --- a/testsuite/tests/lib-scanf/tscanf.ml +++ b/testsuite/tests/lib-scanf/tscanf.ml @@ -104,6 +104,12 @@ let test4 () = test (test4 ()) ;; +let same_float x y = + let is_nan z = (z <> z) in + if is_nan x then is_nan y + else Int64.bits_of_float y = Int64.bits_of_float x +;; + (* e style. *) let test5 () = bscanf (Scanning.from_string "1e1") @@ -122,6 +128,54 @@ let test5 () = "%g %g %g %g" (fun b1 b2 b3 b4 -> b1 = 1.0 && b2 = 1.1 && b3 = 0.0 && b4 = 0.13) + && +(* F style *) + bscanf (Scanning.from_string "1.5 1.5e0 15e-1 0x1.8 0X1.8") + "%F %F %f %F %F" + (fun b1 b2 b3 b4 b5 -> b1 = b2 && b2 = b3 && b3 = b4 && b4 = b5) + && +(* h style *) + begin + let roundtrip x = + bscanf (Printf.ksprintf Scanning.from_string "%h" x) "%h" (same_float x) + in + roundtrip (+0.) && + roundtrip (-0.) && + roundtrip (+1.) && + roundtrip (-1.) && + roundtrip (+1024.) && + roundtrip (-1024.) && + roundtrip 0X123.456 && + roundtrip 0X123456789ABCDE. && + roundtrip epsilon_float && + roundtrip nan && + roundtrip infinity && + roundtrip neg_infinity && + roundtrip (4. *. atan 1.) && + true + end + && + + (* H style *) + begin + let roundtrip x = + bscanf (Printf.ksprintf Scanning.from_string "%H" x) "%H" (same_float x) + in + roundtrip (+0.) && + roundtrip (-0.) && + roundtrip (+1.) && + roundtrip (-1.) && + roundtrip (+1024.) && + roundtrip (-1024.) && + roundtrip 0X123.456 && + roundtrip 0X123456789ABCDE. && + roundtrip epsilon_float && + roundtrip nan && + roundtrip infinity && + roundtrip neg_infinity && + roundtrip (4. *. atan 1.) && + true + end ;; test (test5 ()) diff --git a/testsuite/tests/lib-set/testmap.ml b/testsuite/tests/lib-set/testmap.ml index 1dd919a249..4cbf36c62a 100644 --- a/testsuite/tests/lib-set/testmap.ml +++ b/testsuite/tests/lib-set/testmap.ml @@ -132,3 +132,53 @@ let rmap() = let _ = Random.init 42; for i = 1 to 10000 do test (rkey()) (rdata()) (rmap()) (rmap()) done + +let () = + (* check that removing a binding from a map that is not present in this map + (1) doesn't allocate and (2) return the original map *) + let m1 = ref M.empty in + for i = 1 to 10 do m1 := M.add i (float i) !m1 done; + let m2 = ref !m1 in + + let a0 = Gc.allocated_bytes () in + let a1 = Gc.allocated_bytes () in + for i = 11 to 30 do m2 := M.remove i !m2 done; + let a2 = Gc.allocated_bytes () in + + assert (!m2 == !m1); + assert(a2 -. a1 = a1 -. a0) + +let () = + (* check that filtering a map where all bindings are satisfied by + the given predicate returns the original map *) + let m1 = ref M.empty in + for i = 1 to 10 do m1 := M.add i (float i) !m1 done; + let m2 = M.filter (fun e _ -> e >= 0) !m1 in + assert (m2 == !m1) + +let () = + (* check that adding a binding "x -> y" to a map that already + contains it doesn't allocate and return the original map. *) + let m1 = ref M.empty in + let tmp = ref None in + for i = 1 to 10 do + tmp := Some (float i); + m1 := M.add i !tmp !m1 + done; + let m2 = ref !m1 in + + let a0 = Gc.allocated_bytes () in + let a1 = Gc.allocated_bytes () in + + (* 10 |-> !tmp is already present in !m2 *) + m2 := M.add 10 !tmp !m2; + + let a2 = Gc.allocated_bytes () in + + assert (!m2 == !m1); + assert(a2 -. a1 = a1 -. a0); + + (* 4 |-> Some 84. is not present in !m2 *) + m2 := M.add 4 (Some 84.) !m2; + + assert (not (!m2 == !m1)); diff --git a/testsuite/tests/lib-stack/Makefile b/testsuite/tests/lib-stack/Makefile new file mode 100644 index 0000000000..299656b246 --- /dev/null +++ b/testsuite/tests/lib-stack/Makefile @@ -0,0 +1,15 @@ +######################################################################### +# # +# OCaml # +# # +# Xavier Clerc, SED, INRIA Rocquencourt # +# # +# Copyright 2010 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.several +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/lib-stack/test.ml b/testsuite/tests/lib-stack/test.ml new file mode 100644 index 0000000000..e8df9a2649 --- /dev/null +++ b/testsuite/tests/lib-stack/test.ml @@ -0,0 +1,127 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the S Public License version 1.0. *) +(* *) +(***********************************************************************) + +module S = struct + include Stack + + let to_list s = let l = ref [] in iter (fun x -> l := x :: !l) s; !l (* from bottom to top *) +end + +let does_raise f s = + try + ignore (f s : int); + false + with S.Empty -> + true + +let () = + let s = S.create () in + (); assert (S.to_list s = [ ] && S.length s = 0); + S.push 1 s; assert (S.to_list s = [1 ] && S.length s = 1); + S.push 2 s; assert (S.to_list s = [1; 2 ] && S.length s = 2); + S.push 3 s; assert (S.to_list s = [1; 2; 3 ] && S.length s = 3); + S.push 4 s; assert (S.to_list s = [1; 2; 3; 4] && S.length s = 4); + assert (S.pop s = 4); assert (S.to_list s = [1; 2; 3; ] && S.length s = 3); + assert (S.pop s = 3); assert (S.to_list s = [1; 2; ] && S.length s = 2); + assert (S.pop s = 2); assert (S.to_list s = [1; ] && S.length s = 1); + assert (S.pop s = 1); assert (S.to_list s = [ ] && S.length s = 0); + assert (does_raise S.pop s); +;; + +let () = + let s = S.create () in + S.push 1 s; assert (S.pop s = 1); assert (does_raise S.pop s); + S.push 2 s; assert (S.pop s = 2); assert (does_raise S.pop s); + assert (S.length s = 0); +;; + +let () = + let s = S.create () in + S.push 1 s; assert (S.top s = 1); + S.push 2 s; assert (S.top s = 2); + S.push 3 s; assert (S.top s = 3); + assert (S.top s = 3); assert (S.pop s = 3); + assert (S.top s = 2); assert (S.pop s = 2); + assert (S.top s = 1); assert (S.pop s = 1); + assert (does_raise S.top s); + assert (does_raise S.top s); +;; + +let () = + let s = S.create () in + for i = 1 to 10 do S.push i s done; + S.clear s; + assert (S.length s = 0); + assert (does_raise S.pop s); + assert (s = S.create ()); + S.push 42 s; + assert (S.pop s = 42); +;; + +let () = + let s1 = S.create () in + for i = 1 to 10 do S.push i s1 done; + let s2 = S.copy s1 in + assert (S.to_list s1 = [1; 2; 3; 4; 5; 6; 7; 8; 9; 10]); + assert (S.to_list s2 = [1; 2; 3; 4; 5; 6; 7; 8; 9; 10]); + assert (S.length s1 = 10); + assert (S.length s2 = 10); + for i = 10 downto 1 do + assert (S.pop s1 = i); + done; + for i = 10 downto 1 do + assert (S.pop s2 = i); + done; +;; + +let () = + let s = S.create () in + assert (S.is_empty s); + for i = 1 to 10 do + S.push i s; + assert (S.length s = i); + assert (not (S.is_empty s)); + done; + for i = 10 downto 1 do + assert (S.length s = i); + assert (not (S.is_empty s)); + ignore (S.pop s : int); + done; + assert (S.length s = 0); + assert (S.is_empty s); +;; + +let () = + let s = S.create () in + for i = 10 downto 1 do S.push i s done; + let i = ref 1 in + S.iter (fun j -> assert (!i = j); incr i) s; +;; + +let () = + let s1 = S.create () in + assert (S.length s1 = 0); assert (S.to_list s1 = []); + let s2 = S.copy s1 in + assert (S.length s1 = 0); assert (S.to_list s1 = []); + assert (S.length s2 = 0); assert (S.to_list s2 = []); +;; + +let () = + let s1 = S.create () and s2 = S.create () in + for i = 1 to 4 do S.push i s1 done; + assert (S.length s1 = 4); assert (S.to_list s1 = [1; 2; 3; 4]); + let s2 = S.copy s1 in + assert (S.length s1 = 4); assert (S.to_list s1 = [1; 2; 3; 4]); + assert (S.length s2 = 4); assert (S.to_list s2 = [1; 2; 3; 4]); +;; + +let () = print_endline "OK" diff --git a/testsuite/tests/lib-stack/test.reference b/testsuite/tests/lib-stack/test.reference new file mode 100644 index 0000000000..d86bac9de5 --- /dev/null +++ b/testsuite/tests/lib-stack/test.reference @@ -0,0 +1 @@ +OK diff --git a/testsuite/tests/regression/pr7042/Makefile b/testsuite/tests/regression/pr7042/Makefile new file mode 100644 index 0000000000..334f8ff7b4 --- /dev/null +++ b/testsuite/tests/regression/pr7042/Makefile @@ -0,0 +1,17 @@ +######################################################################### +# # +# OCaml # +# # +# Damien Doligez, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2013 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +MAIN_MODULE=pr7042 + +BASEDIR=../../.. +include $(BASEDIR)/makefiles/Makefile.one +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/regression/pr7042/pr7042.ml b/testsuite/tests/regression/pr7042/pr7042.ml new file mode 100644 index 0000000000..32c64c53f7 --- /dev/null +++ b/testsuite/tests/regression/pr7042/pr7042.ml @@ -0,0 +1,17 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +let _ = + let a = [| 0.0; -. 0.0 |] in + Printf.printf "%Lx %Lx\n" + (Int64.bits_of_float a.(0)) (Int64.bits_of_float a.(1)) + diff --git a/testsuite/tests/regression/pr7042/pr7042.reference b/testsuite/tests/regression/pr7042/pr7042.reference new file mode 100644 index 0000000000..c6a412a469 --- /dev/null +++ b/testsuite/tests/regression/pr7042/pr7042.reference @@ -0,0 +1 @@ +0 8000000000000000 diff --git a/testsuite/tests/typing-extension-constructor/Makefile b/testsuite/tests/typing-extension-constructor/Makefile new file mode 100644 index 0000000000..c9433b2ecb --- /dev/null +++ b/testsuite/tests/typing-extension-constructor/Makefile @@ -0,0 +1,15 @@ +######################################################################### +# # +# OCaml # +# # +# Xavier Clerc, SED, INRIA Rocquencourt # +# # +# Copyright 2010 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +BASEDIR=../.. +include $(BASEDIR)/makefiles/Makefile.toplevel +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/typing-extension-constructor/test.ml b/testsuite/tests/typing-extension-constructor/test.ml new file mode 100644 index 0000000000..f40f275269 --- /dev/null +++ b/testsuite/tests/typing-extension-constructor/test.ml @@ -0,0 +1,21 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jeremie Dimino, Jane Street Europe *) +(* *) +(* Copyright 2015 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +type t = ..;; +type t += A;; + +[%extension_constructor A];; +([%extension_constructor A] : extension_constructor);; + +type extension_constructor = int;; + +([%extension_constructor A] : extension_constructor);; diff --git a/testsuite/tests/typing-extension-constructor/test.ml.reference b/testsuite/tests/typing-extension-constructor/test.ml.reference new file mode 100644 index 0000000000..ae63c27823 --- /dev/null +++ b/testsuite/tests/typing-extension-constructor/test.ml.reference @@ -0,0 +1,13 @@ + +# type t = .. +# type t += A +# - : extension_constructor = <abstr> +# - : extension_constructor = <abstr> +# type extension_constructor = int +# Characters 2-28: + ([%extension_constructor A] : extension_constructor);; + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This expression has type extension_constructor/16 + but an expression was expected of type + extension_constructor/1214 = int +# diff --git a/testsuite/tests/typing-extensions/extensions.ml b/testsuite/tests/typing-extensions/extensions.ml index 3539be332f..edb14c8b22 100644 --- a/testsuite/tests/typing-extensions/extensions.ml +++ b/testsuite/tests/typing-extensions/extensions.ml @@ -296,19 +296,22 @@ type foo += | Bar of int ;; -let n1 = Obj.extension_name Foo +let extension_name e = Obj.extension_name (Obj.extension_constructor e);; +let extension_id e = Obj.extension_id (Obj.extension_constructor e);; + +let n1 = extension_name Foo ;; -let n2 = Obj.extension_name (Bar 1) +let n2 = extension_name (Bar 1) ;; -let t = (Obj.extension_id (Bar 2)) = (Obj.extension_id (Bar 3)) (* true *) +let t = (extension_id (Bar 2)) = (extension_id (Bar 3)) (* true *) ;; -let f = (Obj.extension_id (Bar 2)) = (Obj.extension_id Foo) (* false *) +let f = (extension_id (Bar 2)) = (extension_id Foo) (* false *) ;; -let is_foo x = (Obj.extension_id Foo) = (Obj.extension_id x) +let is_foo x = (extension_id Foo) = (extension_id x) type foo += Foo ;; @@ -316,8 +319,8 @@ type foo += Foo let f = is_foo Foo ;; -let _ = Obj.extension_name 7 (* Invald_arg *) +let _ = Obj.extension_constructor 7 (* Invald_arg *) ;; -let _ = Obj.extension_id (object method m = 3 end) (* Invald_arg *) +let _ = Obj.extension_constructor (object method m = 3 end) (* Invald_arg *) ;; diff --git a/testsuite/tests/typing-extensions/extensions.ml.reference b/testsuite/tests/typing-extensions/extensions.ml.reference index 2f827076ec..2a9183f77e 100644 --- a/testsuite/tests/typing-extensions/extensions.ml.reference +++ b/testsuite/tests/typing-extensions/extensions.ml.reference @@ -119,6 +119,8 @@ Error: This extension does not match the definition of type bar # val y : exn * exn = (Foo (3, _), Bar (Some 5)) # type foo = .. # type foo += Foo | Bar of int +# val extension_name : 'a -> string = <fun> +# val extension_id : 'a -> int = <fun> # val n1 : string = "Foo" # val n2 : string = "Bar" # val t : bool = true @@ -126,6 +128,6 @@ Error: This extension does not match the definition of type bar # val is_foo : 'a -> bool = <fun> type foo += Foo # val f : bool = false -# Exception: Invalid_argument "Obj.extension_name". -# Exception: Invalid_argument "Obj.extension_id". +# Exception: Invalid_argument "Obj.extension_constructor". +# Exception: Invalid_argument "Obj.extension_constructor". # diff --git a/testsuite/tests/typing-warnings/exhaustiveness.ml b/testsuite/tests/typing-warnings/exhaustiveness.ml index 57aac3f13c..c2bc919fe9 100644 --- a/testsuite/tests/typing-warnings/exhaustiveness.ml +++ b/testsuite/tests/typing-warnings/exhaustiveness.ml @@ -94,4 +94,12 @@ let inv_zero : type a b c d. (a,b,c) plus -> (c,d,zero) plus -> bool = (* Empty match *) type _ t = Int : int t;; -let f (x : bool t) = match x with _ -> . ;; +let f (x : bool t) = match x with _ -> . ;; (* ok *) + + +(* trefis in PR#6437 *) + +let f () = match None with _ -> .;; (* error *) +let g () = match None with _ -> () | exception _ -> .;; (* error *) +let h () = match None with _ -> . | exception _ -> .;; (* error *) +let f x = match x with _ -> () | None -> .;; (* do not warn *) diff --git a/testsuite/tests/typing-warnings/exhaustiveness.ml.reference b/testsuite/tests/typing-warnings/exhaustiveness.ml.reference index 1aa8469053..471599a458 100644 --- a/testsuite/tests/typing-warnings/exhaustiveness.ml.reference +++ b/testsuite/tests/typing-warnings/exhaustiveness.ml.reference @@ -97,4 +97,20 @@ val harder : (zero succ, zero succ, zero succ) plus option -> bool = <fun> # val inv_zero : ('a, 'b, 'c) plus -> ('c, 'd, zero) plus -> bool = <fun> # type _ t = Int : int t # val f : bool t -> 'a = <fun> +# Characters 54-55: + let f () = match None with _ -> .;; (* error *) + ^ +Error: This match case could not be refuted. + Here is an example of a value that would reach it: _ +# Characters 47-48: + let g () = match None with _ -> () | exception _ -> .;; (* error *) + ^ +Error: This match case could not be refuted. + Here is an example of a value that would reach it: _ +# Characters 27-28: + let h () = match None with _ -> . | exception _ -> .;; (* error *) + ^ +Error: This match case could not be refuted. + Here is an example of a value that would reach it: _ +# val f : 'a option -> unit = <fun> # diff --git a/tools/depend.ml b/tools/depend.ml index b9c84368e7..92b6cdc9ae 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -200,6 +200,12 @@ let rec add_expr bv exp = | Pexp_newtype (_, e) -> add_expr bv e | Pexp_pack m -> add_module bv m | Pexp_open (_ovf, m, e) -> open_module bv m.txt; add_expr bv e + | Pexp_extension ({ txt = ("ocaml.extension_constructor"|"extension_constructor"); _ }, + PStr [item]) -> + begin match item.pstr_desc with + | Pstr_eval ({ pexp_desc = Pexp_construct (c, None) }, _) -> add bv c + | _ -> () + end | Pexp_extension _ -> () | Pexp_unreachable -> () diff --git a/typing/btype.ml b/typing/btype.ml index 7627913c9e..5216deb9a4 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -69,6 +69,7 @@ let rec field_kind_repr = Fvar {contents = Some kind} -> field_kind_repr kind | kind -> kind +(* let rec repr = function {desc = Tlink t'} -> @@ -82,6 +83,11 @@ let rec repr = | {desc = Tfield (_, k, _, t')} when field_kind_repr k = Fabsent -> repr t' | t -> t +*) + +(* Path compression must be undone by backtracking *) +let repr_link' = ref (fun _ -> assert false) +let repr t = !repr_link' 0 t t.desc t let rec commu_repr = function Clink r when !r <> Cunknown -> commu_repr !r @@ -497,10 +503,16 @@ let unmark_class_type cty = (*******************************************) (* Search whether the expansion has been memorized. *) + +let lte_public p1 p2 = (* Private <= Public *) + match p1, p2 with + | Private, _ | _, Public -> true + | Public, Private -> false + let rec find_expans priv p1 = function Mnil -> None | Mcons (priv', p2, ty0, ty, _) - when priv' >= priv && Path.same p1 p2 -> Some ty + when lte_public priv priv' && Path.same p1 p2 -> Some ty | Mcons (_, _, _, _, rem) -> find_expans priv p1 rem | Mlink {contents = rem} -> find_expans priv p1 rem @@ -589,6 +601,7 @@ let extract_label l ls = extract_label_aux [] l ls type change = Ctype of type_expr * type_desc + | Ccompress of type_expr * type_desc * type_desc | Clevel of type_expr * int | Cname of (Path.t * type_expr list) option ref * (Path.t * type_expr list) option @@ -600,6 +613,7 @@ type change = let undo_change = function Ctype (ty, desc) -> ty.desc <- desc + | Ccompress (ty, desc, _) -> ty.desc <- desc | Clevel (ty, level) -> ty.level <- level | Cname (r, v) -> r := v | Crow (r, v) -> r := v @@ -689,3 +703,41 @@ let backtrack (changes, old) = changes := Unchanged; last_snapshot := old; Weak.set trail 0 (Some changes) + +let rec rev_compress_log log r = + match !r with + Unchanged | Invalid -> + log + | Change (Ccompress _, next) -> + rev_compress_log (r::log) next + | Change (_, next) -> + rev_compress_log log next + +let undo_compress (changes, old) = + match !changes with + Unchanged + | Invalid -> () + | Change _ -> + let log = rev_compress_log [] changes in + List.iter + (fun r -> match !r with + Change (Ccompress (ty, desc, d), next) when ty.desc == d -> + ty.desc <- desc; r := !next + | _ -> ()) + log + +let rec repr_link n t d = + function + {desc = Tlink t' as d'} -> + repr_link (succ n) t d' t' + | {desc = Tfield (_, k, _, t') as d'} when field_kind_repr k = Fabsent -> + repr_link (succ n) t d' t' + | t' -> + if n > 1 then begin + log_change (Ccompress (t, t.desc, d)); t.desc <- d + end; + t' + +let () = repr_link' := repr_link + +let repr t = repr_link 0 t t.desc t diff --git a/typing/btype.mli b/typing/btype.mli index 4e1b1413c3..67c6e761b0 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -183,6 +183,10 @@ val backtrack: snapshot -> unit (* Backtrack to a given snapshot. Only possible if you have not already backtracked to a previous snapshot. Calls [cleanup_abbrev] internally *) +val undo_compress: snapshot -> unit + (* Backtrack only path compression. Only meaningful if you have + not already backtracked to a previous snapshot. + Does not call [cleanup_abbrev] *) (* Functions to use when modifying a type (only Ctype?) *) val link_type: type_expr -> type_expr -> unit diff --git a/typing/ctype.ml b/typing/ctype.ml index 3ba0a686d3..c1df6c0b5f 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -1575,58 +1575,12 @@ let generic_private_abbrev env path = | _ -> false with Not_found -> false -let is_contractive env ty = - try match (repr ty).desc with - Tconstr (p, _, _) -> - let decl = Env.find_type p env in - in_pervasives p && decl.type_manifest = None || is_datatype decl - | _ -> true +let is_contractive env p = + try + let decl = Env.find_type p env in + in_pervasives p && decl.type_manifest = None || is_datatype decl with Not_found -> false -(* Code moved to Typedecl - -(* The marks are already used by [expand_abbrev]... *) -let visited = ref [] - -let rec non_recursive_abbrev env ty0 ty = - let ty = repr ty in - if ty == repr ty0 then raise Recursive_abbrev; - if not (List.memq ty !visited) then begin - visited := ty :: !visited; - match ty.desc with - Tconstr(p, args, abbrev) -> - begin try - non_recursive_abbrev env ty0 (try_expand_once_opt env ty) - with Cannot_expand -> - if !Clflags.recursive_types && - (in_pervasives p || - try is_datatype (Env.find_type p env) with Not_found -> false) - then () - else iter_type_expr (non_recursive_abbrev env ty0) ty - end - | Tobject _ | Tvariant _ -> - () - | _ -> - if !Clflags.recursive_types then () else - iter_type_expr (non_recursive_abbrev env ty0) ty - end - -let correct_abbrev env path params ty = - check_abbrev_env env; - let ty0 = newgenvar () in - visited := []; - let abbrev = Mcons (Public, path, ty0, ty0, Mnil) in - simple_abbrevs := abbrev; - try - non_recursive_abbrev env ty0 - (subst env generic_level Public (ref abbrev) None [] [] ty); - simple_abbrevs := Mnil; - visited := [] - with exn -> - simple_abbrevs := Mnil; - visited := []; - raise exn -*) (*****************) (* Occur check *) @@ -1635,39 +1589,46 @@ let correct_abbrev env path params ty = exception Occur -let allow_recursive env ty = - (!Clflags.recursive_types || !umode = Pattern) && is_contractive env ty - -let rec occur_rec env visited ty0 ty = +let rec occur_rec env allow_recursive visited ty0 = function + | {desc=Tlink ty} -> + occur_rec env allow_recursive visited ty0 ty + | ty -> if ty == ty0 then raise Occur; - if allow_recursive env ty then () else match ty.desc with Tconstr(p, tl, abbrev) -> + if allow_recursive && is_contractive env p then () else begin try - if List.memq ty visited then raise Occur; - iter_type_expr (occur_rec env (ty::visited) ty0) ty + if TypeSet.mem ty visited then raise Occur; + let visited = TypeSet.add ty visited in + iter_type_expr (occur_rec env allow_recursive visited ty0) ty with Occur -> try let ty' = try_expand_head try_expand_once env ty in (* This call used to be inlined, but there seems no reason for it. Message was referring to change in rev. 1.58 of the CVS repo. *) - occur_rec env visited ty0 ty' + occur_rec env allow_recursive visited ty0 ty' with Cannot_expand -> raise Occur end | Tobject _ | Tvariant _ -> () | _ -> - if List.memq ty visited then () else - iter_type_expr (occur_rec env (ty::visited) ty0) ty + if allow_recursive || TypeSet.mem ty visited then () else begin + let visited = TypeSet.add ty visited in + iter_type_expr (occur_rec env allow_recursive visited ty0) ty + end let type_changed = ref false (* trace possible changes to the studied type *) let merge r b = if b then r := true let occur env ty0 ty = + let allow_recursive = !Clflags.recursive_types || !umode = Pattern in let old = !type_changed in try - while type_changed := false; occur_rec env [] ty0 ty; !type_changed + while + type_changed := false; + occur_rec env allow_recursive TypeSet.empty ty0 ty; + !type_changed do () (* prerr_endline "changed" *) done; merge type_changed old with exn -> @@ -1687,7 +1648,7 @@ let rec local_non_recursive_abbrev visited env p ty = match ty.desc with Tconstr(p', args, abbrev) -> if Path.same p p' then raise Occur; - if is_contractive env ty then () else + if is_contractive env p' then () else let visited = ty :: visited in begin try List.iter (local_non_recursive_abbrev visited env p) args @@ -2754,12 +2715,15 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 = let unify env ty1 ty2 = + let snap = Btype.snapshot () in try unify env ty1 ty2 with Unify trace -> + undo_compress snap; raise (Unify (expand_trace !env trace)) | Recursive_abbrev -> + undo_compress snap; raise (Unification_recursive_abbrev (expand_trace !env [(ty1,ty2)])) let unify_gadt ~newtype_level:lev (env:Env.t ref) ty1 ty2 = diff --git a/typing/ctype.mli b/typing/ctype.mli index b4618d23f4..90bfcbe6de 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -248,7 +248,7 @@ val nondep_cltype_declaration: (* Same for class type declarations. *) (*val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit*) val cyclic_abbrev: Env.t -> Ident.t -> type_expr -> bool -val is_contractive: Env.t -> type_expr -> bool +val is_contractive: Env.t -> Path.t -> bool val normalize_type: Env.t -> type_expr -> unit val closed_schema: Env.t -> type_expr -> bool diff --git a/typing/env.ml b/typing/env.ml index ca5093a968..3b991fddff 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -996,24 +996,27 @@ let lookup_cltype lid env = type iter_cont = unit -> unit let iter_env_cont = ref [] -let rec scrape_alias_safe env mty = +let rec scrape_alias_for_visit env mty = match mty with - | Mty_alias (Pident id) when Ident.persistent id -> false + | Mty_alias (Pident id) + when Ident.persistent id + && not (Hashtbl.mem persistent_structures (Ident.name id)) -> false | Mty_alias path -> (* PR#6600: find_module may raise Not_found *) - scrape_alias_safe env (find_module path env).md_type + begin try scrape_alias_for_visit env (find_module path env).md_type + with Not_found -> false + end | _ -> true let iter_env proj1 proj2 f env () = Ident.iter (fun id (x,_) -> f (Pident id) x) (proj1 env); let rec iter_components path path' mcomps = let cont () = - let safe = + let visit = match EnvLazy.get_arg mcomps with - None -> true - | Some (env, sub, path, mty) -> - try scrape_alias_safe env mty with Not_found -> false + | None -> true + | Some (env, sub, path, mty) -> scrape_alias_for_visit env mty in - if not safe then () else + if not visit then () else match EnvLazy.force !components_of_module_maker' mcomps with Structure_comps comps -> Tbl.iter diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 66fd2a80a3..76ce11de9e 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -1925,12 +1925,12 @@ let check_unused pred tdefs casel = (* First look for redundant or partially redundant patterns *) let r = every_satisfiables (make_rows pss) (make_row qs) in let refute = (c_rhs.exp_desc = Texp_unreachable) in - (* Do not warn for unused _ -> _ *) - if r = Unused && refute && q.pat_desc = Tpat_any then () else + (* Do not warn for unused [pat -> .] *) + if r = Unused && refute then () else let r = (* Do not refine if there are no other lines *) let skip = - r = Unused || pref = [] || + r = Unused || (not refute && pref = []) || not(refute || Warnings.is_active Warnings.Unreachable_case) in if skip then r else (* Then look for empty patterns *) diff --git a/typing/predef.ml b/typing/predef.ml index 9903cda270..10def35869 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -41,6 +41,7 @@ and ident_int32 = ident_create "int32" and ident_int64 = ident_create "int64" and ident_lazy_t = ident_create "lazy_t" and ident_string = ident_create "string" +and ident_extension_constructor = ident_create "extension_constructor" let path_int = Pident ident_int and path_char = Pident ident_char @@ -57,6 +58,7 @@ and path_int32 = Pident ident_int32 and path_int64 = Pident ident_int64 and path_lazy_t = Pident ident_lazy_t and path_string = Pident ident_string +and path_extension_constructor = Pident ident_extension_constructor let type_int = newgenty (Tconstr(path_int, [], ref Mnil)) and type_char = newgenty (Tconstr(path_char, [], ref Mnil)) @@ -73,6 +75,7 @@ and type_int32 = newgenty (Tconstr(path_int32, [], ref Mnil)) and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil)) and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil)) and type_string = newgenty (Tconstr(path_string, [], ref Mnil)) +and type_extension_constructor = newgenty (Tconstr(path_extension_constructor, [], ref Mnil)) let ident_match_failure = ident_create_predef_exn "Match_failure" and ident_out_of_memory = ident_create_predef_exn "Out_of_memory" @@ -198,7 +201,8 @@ let common_initial_env add_type add_extension empty_env = add_type ident_string decl_abstr ( add_type ident_char decl_abstr ( add_type ident_int decl_abstr ( - empty_env)))))))))))))))))))))))))) + add_type ident_extension_constructor decl_abstr ( + empty_env))))))))))))))))))))))))))) let build_initial_env add_type add_exception empty_env = let common = common_initial_env add_type add_exception empty_env in diff --git a/typing/predef.mli b/typing/predef.mli index 9723671165..b72e2356c2 100644 --- a/typing/predef.mli +++ b/typing/predef.mli @@ -29,6 +29,7 @@ val type_nativeint: type_expr val type_int32: type_expr val type_int64: type_expr val type_lazy_t: type_expr -> type_expr +val type_extension_constructor:type_expr val path_int: Path.t val path_char: Path.t @@ -45,6 +46,7 @@ val path_nativeint: Path.t val path_int32: Path.t val path_int64: Path.t val path_lazy_t: Path.t +val path_extension_constructor: Path.t val path_match_failure: Path.t val path_assert_failure : Path.t diff --git a/typing/printtyp.ml b/typing/printtyp.ml index e76fe7efeb..4cac3270bc 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -277,10 +277,21 @@ let rec normalize_type_path ?(cache=false) env p = with Not_found -> (p, Id) +let penalty s = + if s <> "" && s.[0] = '_' then + 10 + else + try + for i = 0 to String.length s - 2 do + if s.[i] = '_' && s.[i + 1] = '_' then + raise Exit + done; + 1 + with Exit -> 10 + let rec path_size = function Pident id -> - (let s = Ident.name id in if s <> "" && s.[0] = '_' then 10 else 1), - -Ident.binding_time id + penalty (Ident.name id), -Ident.binding_time id | Pdot (p, _, _) -> let (l, b) = path_size p in (1+l, b) | Papply (p1, p2) -> @@ -360,7 +371,7 @@ let best_type_path p = let (p', s) = normalize_type_path !printing_env p in let get_path () = get_best_path (PathMap.find p' !printing_map) in while !printing_cont <> [] && - try ignore (get_path ()); false with Not_found -> true + try fst (path_size (get_path ())) > !printing_depth with Not_found -> true do printing_cont := List.map snd (Env.run_iter_cont !printing_cont); incr printing_depth; diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 315fe83920..68ac2718e1 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -373,6 +373,8 @@ and expression i ppf x = module_expr i ppf me | Texp_unreachable -> line i ppf "Texp_unreachable" + | Texp_extension_constructor (li, _) -> + line i ppf "Texp_extension_constructor %a" fmt_longident li and value_description i ppf x = line i ppf "value_description %a %a\n" fmt_ident x.val_id fmt_location @@ -818,7 +820,7 @@ and longident_x_expression i ppf (li, _, e) = line i ppf "%a\n" fmt_longident li; expression (i+1) ppf e; -and label_x_expression i ppf (l, e, _) = +and label_x_expression i ppf (l, e) = line i ppf "<arg>\n"; arg_label (i+1) ppf l; (match e with None -> () | Some e -> expression (i+1) ppf e) diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml index 02b4c5d368..0524bd0e37 100644 --- a/typing/tast_mapper.ml +++ b/typing/tast_mapper.ml @@ -231,7 +231,7 @@ let expr sub x = | Texp_apply (exp, list) -> Texp_apply ( sub.expr sub exp, - List.map (tuple3 id (opt (sub.expr sub)) id) list + List.map (tuple2 id (opt (sub.expr sub))) list ) | Texp_match (exp, cases, exn_cases, p) -> Texp_match ( @@ -330,6 +330,8 @@ let expr sub x = Texp_pack (sub.module_expr sub mexpr) | Texp_unreachable -> Texp_unreachable + | Texp_extension_constructor _ as e -> + e in {x with exp_extra; exp_desc; exp_env} @@ -461,7 +463,7 @@ let module_expr sub x = {x with mod_desc; mod_env} let module_binding sub x = - let mb_expr = module_expr sub x.mb_expr in + let mb_expr = sub.module_expr sub x.mb_expr in {x with mb_expr} let class_expr sub x = @@ -489,7 +491,7 @@ let class_expr sub x = | Tcl_apply (cl, args) -> Tcl_apply ( sub.class_expr sub cl, - List.map (tuple3 id (opt (sub.expr sub)) id) args + List.map (tuple2 id (opt (sub.expr sub))) args ) | Tcl_let (rec_flag, value_bindings, ivars, cl) -> let (rec_flag, value_bindings) = diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 88ad343907..f25ff7a8ca 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -1016,8 +1016,7 @@ and class_expr cl_num val_env met_env scl = | Cty_arrow (l, ty, ty_fun), Cty_arrow (_, ty0, ty_fun0) when sargs <> [] || more_sargs <> [] -> let name = Btype.label_name l - and optional = - if Btype.is_optional l then Optional else Required in + and optional = Btype.is_optional l in let sargs, more_sargs, arg = if ignore_labels && not (Btype.is_optional l) then begin match sargs, more_sargs with @@ -1042,11 +1041,11 @@ and class_expr cl_num val_env met_env scl = Btype.extract_label name more_sargs in (l', sarg0, sargs @ sargs1, sargs2) in - if optional = Required && Btype.is_optional l' then + if not optional && Btype.is_optional l' then Location.prerr_warning sarg0.pexp_loc (Warnings.Nonoptional_label (Printtyp.string_of_label l)); sargs, more_sargs, - if optional = Required || Btype.is_optional l' then + if not optional || Btype.is_optional l' then Some (type_argument val_env sarg0 ty ty0) else let ty' = extract_option_type val_env ty @@ -1063,7 +1062,7 @@ and class_expr cl_num val_env met_env scl = else None in let omitted = if arg = None then (l,ty0) :: omitted else omitted in - type_args ((l,arg,optional)::args) omitted ty_fun ty_fun0 + type_args ((l,arg)::args) omitted ty_fun ty_fun0 sargs more_sargs | _ -> match sargs @ more_sargs with diff --git a/typing/typecore.ml b/typing/typecore.ml index cf7c2ed1a8..e76ea19615 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -69,6 +69,8 @@ type error = | Exception_pattern_below_toplevel | Inlined_record_escape | Unrefuted_pattern of pattern + | Invalid_extension_constructor_payload + | Not_an_extension_constructor exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -1519,8 +1521,8 @@ let rec is_nonexpansive exp = List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list && is_nonexpansive body | Texp_function _ -> true - | Texp_apply(e, (_,None,_)::el) -> - is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd3 el) + | Texp_apply(e, (_,None)::el) -> + is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el) | Texp_match(e, cases, [], _) -> is_nonexpansive e && List.for_all @@ -2511,8 +2513,8 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = exp_loc = obj.exp_loc; exp_extra = []; exp_type = desc.val_type; exp_attributes = []; (* check *) - exp_env = env}, - Required ]) + exp_env = env} + ]) in (Tmeth_name met, Some (re {exp_desc = exp; exp_loc = loc; exp_extra = []; @@ -2839,6 +2841,27 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = sexp.pexp_attributes) :: exp.exp_extra; } + + | Pexp_extension ({ txt = ("ocaml.extension_constructor"|"extension_constructor"); _ }, + payload) -> + begin match payload with + | PStr [ { pstr_desc = + Pstr_eval ({ pexp_desc = Pexp_construct (lid, None); _ }, _) + } ] -> + let path = + match (Typetexp.find_constructor env lid.loc lid.txt).cstr_tag with + | Cstr_extension (path, _) -> path + | _ -> raise (Error (lid.loc, env, Not_an_extension_constructor)) + in + rue { + exp_desc = Texp_extension_constructor (lid, path); + exp_loc = loc; exp_extra = []; + exp_type = instance_def Predef.type_extension_constructor; + exp_attributes = sexp.pexp_attributes; + exp_env = env } + | _ -> + raise (Error (loc, env, Invalid_extension_constructor_payload)) + end | Pexp_extension ext -> raise (Error_forward (Typetexp.error_of_extension ext)) @@ -3006,6 +3029,12 @@ and type_format loc str env = | Float_G -> mk_constr "Float_G" [] | Float_pG -> mk_constr "Float_pG" [] | Float_sG -> mk_constr "Float_sG" [] + | Float_h -> mk_constr "Float_h" [] + | Float_ph -> mk_constr "Float_ph" [] + | Float_sh -> mk_constr "Float_sh" [] + | Float_H -> mk_constr "Float_H" [] + | Float_pH -> mk_constr "Float_pH" [] + | Float_sH -> mk_constr "Float_sH" [] | Float_F -> mk_constr "Float_F" [] and mk_counter cnt = match cnt with | Line_counter -> mk_constr "Line_counter" [] @@ -3245,7 +3274,7 @@ and type_argument ?recarg env sarg ty_expected' ty_expected = match (expand_head env ty_fun).desc with | Tarrow (l,ty_arg,ty_fun,_) when is_optional l -> let ty = option_none (instance env ty_arg) sarg.pexp_loc in - make_args ((l, Some ty, Optional) :: args) ty_fun + make_args ((l, Some ty) :: args) ty_fun | Tarrow (l,_,ty_res',_) when l = Nolabel || !Clflags.classic -> List.rev args, ty_fun, no_labels ty_res' | Tvar _ -> List.rev args, ty_fun, false @@ -3282,14 +3311,14 @@ and type_argument ?recarg env sarg ty_expected' ty_expected = {texp with exp_type = ty_res; exp_desc = Texp_apply (texp, - args @ [Nolabel, Some eta_var, Required])} + args @ [Nolabel, Some eta_var])} in { texp with exp_type = ty_fun; exp_desc = Texp_function(Nolabel, [case eta_pat e], Total) } in Location.prerr_warning texp.exp_loc (Warnings.Eliminated_optional_arguments - (List.map (fun (l, _, _) -> Printtyp.string_of_label l) args)); + (List.map (fun (l, _) -> Printtyp.string_of_label l) args)); if warn then Location.prerr_warning texp.exp_loc (Warnings.Without_principality "eliminated optional argument"); if is_nonexpansive texp then func texp else @@ -3321,13 +3350,12 @@ and type_application env funct sargs = let ignored = ref [] in let rec type_unknown_args (args : - (Asttypes.arg_label * (unit -> Typedtree.expression) option * - Typedtree.optional) list) + (Asttypes.arg_label * (unit -> Typedtree.expression) option) list) omitted ty_fun = function [] -> (List.map - (function l, None, x -> l, None, x - | l, Some f, x -> l, Some (f ()), x) + (function l, None -> l, None + | l, Some f -> l, Some (f ())) (List.rev args), instance env (result_type omitted ty_fun)) | (l1, sarg1) :: sargl -> @@ -3364,14 +3392,14 @@ and type_application env funct sargs = raise(Error(funct.exp_loc, env, Apply_non_function (expand_head env funct.exp_type))) in - let optional = if is_optional l1 then Optional else Required in + let optional = is_optional l1 in let arg1 () = let arg1 = type_expect env sarg1 ty1 in - if optional = Optional then + if optional then unify_exp env arg1 (type_option(newvar())); arg1 in - type_unknown_args ((l1, Some arg1, optional) :: args) omitted ty2 sargl + type_unknown_args ((l1, Some arg1) :: args) omitted ty2 sargl in let ignore_labels = !Clflags.classic || @@ -3404,7 +3432,7 @@ and type_application env funct sargs = end in let name = label_name l - and optional = if is_optional l then Optional else Required in + and optional = is_optional l in let sargs, more_sargs, arg = if ignore_labels && not (is_optional l) then begin (* In classic mode, omitted = [] *) @@ -3437,11 +3465,11 @@ and type_application env funct sargs = (Warnings.Not_principal "commuting this argument"); (l', sarg0, sargs @ sargs1, sargs2) in - if optional = Required && is_optional l' then + if not optional && is_optional l' then Location.prerr_warning sarg0.pexp_loc (Warnings.Nonoptional_label (Printtyp.string_of_label l)); sargs, more_sargs, - if optional = Required || is_optional l' then + if not optional || is_optional l' then Some (fun () -> type_argument env sarg0 ty ty0) else begin may_warn sarg0.pexp_loc @@ -3452,7 +3480,7 @@ and type_application env funct sargs = end with Not_found -> sargs, more_sargs, - if optional = Optional && + if optional && (List.mem_assoc Nolabel sargs || List.mem_assoc Nolabel more_sargs) then begin @@ -3469,7 +3497,7 @@ and type_application env funct sargs = let omitted = if arg = None then (l,ty,lv) :: omitted else omitted in let ty_old = if sargs = [] then ty_fun else ty_old in - type_args ((l,arg,optional)::args) omitted ty_fun ty_fun0 + type_args ((l,arg)::args) omitted ty_fun ty_fun0 ty_old sargs more_sargs | _ -> match sargs with @@ -3495,7 +3523,7 @@ and type_application env funct sargs = add_delayed_check (fun () -> check_application_result env false exp) | _ -> () end; - ([Nolabel, Some exp, Required], ty_res) + ([Nolabel, Some exp], ty_res) | _ -> let ty = funct.exp_type in if ignore_labels then @@ -3843,7 +3871,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) (* has one of the identifier of this pattern been used? *) let slot = ref [] in List.iter - (fun (id,_) -> + (fun id -> let vd = Env.find_value (Path.Pident id) new_env in (* note: Env.find_value does not trigger the value_used event *) let name = Ident.name id in @@ -4208,6 +4236,12 @@ let report_error env ppf = function "This match case could not be refuted." "Here is an example of a value that would reach it:" Parmatch.top_pretty pat + | Invalid_extension_constructor_payload -> + fprintf ppf + "Invalid [%%extension_constructor] payload, a constructor is expected." + | Not_an_extension_constructor -> + fprintf ppf + "This constructor is not an extension constructor." let report_error env ppf err = wrap_printing_env env (fun () -> report_error env ppf err) diff --git a/typing/typecore.mli b/typing/typecore.mli index 06942a74a7..5434093ca6 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -114,6 +114,8 @@ type error = | Exception_pattern_below_toplevel | Inlined_record_escape | Unrefuted_pattern of Typedtree.pattern + | Invalid_extension_constructor_payload + | Not_an_extension_constructor exception Error of Location.t * Env.t * error exception Error_forward of Location.error diff --git a/typing/typedecl.ml b/typing/typedecl.ml index e0d8089f06..a2f4a2b3b3 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -518,11 +518,15 @@ let check_well_founded env loc path to_check ty = | _ -> raise Ctype.Cannot_expand with | Ctype.Cannot_expand -> + let rec_ok = + match ty.desc with + Tconstr(p,_,_) -> + !Clflags.recursive_types && Ctype.is_contractive env p + | Tobject _ | Tvariant _ -> true + | _ -> !Clflags.recursive_types + in let nodes = - if !Clflags.recursive_types && Ctype.is_contractive env ty - || match ty.desc with Tobject _ | Tvariant _ -> true | _ -> false - then TypeSet.empty - else exp_nodes in + if rec_ok then TypeSet.empty else exp_nodes in Btype.iter_type_expr (check ty0 nodes) ty | Ctype.Unify _ -> (* Will be detected by check_recursion *) diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 6cd1b7ca1a..16525a6f6c 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -19,7 +19,6 @@ open Types (* Value expressions for the core language *) type partial = Partial | Total -type optional = Required | Optional type attribute = Parsetree.attribute type attributes = attribute list @@ -75,7 +74,7 @@ and expression_desc = | Texp_constant of constant | Texp_let of rec_flag * value_binding list * expression | Texp_function of arg_label * case list * partial - | Texp_apply of expression * (arg_label * expression option * optional) list + | Texp_apply of expression * (arg_label * expression option) list | Texp_match of expression * case list * case list * partial | Texp_try of expression * case list | Texp_tuple of expression list @@ -106,6 +105,7 @@ and expression_desc = | Texp_object of class_structure * string list | Texp_pack of module_expr | Texp_unreachable + | Texp_extension_constructor of Longident.t loc * Path.t and meth = Tmeth_name of string @@ -135,7 +135,7 @@ and class_expr_desc = | Tcl_fun of arg_label * pattern * (Ident.t * string loc * expression) list * class_expr * partial - | Tcl_apply of class_expr * (arg_label * expression option * optional) list + | Tcl_apply of class_expr * (arg_label * expression option) list | Tcl_let of rec_flag * value_binding list * (Ident.t * string loc * expression) list * class_expr | Tcl_constraint of @@ -563,7 +563,11 @@ let rec bound_idents pat = | d -> iter_pattern_desc bound_idents d let pat_bound_idents pat = - idents := []; bound_idents pat; let res = !idents in idents := []; res + idents := []; + bound_idents pat; + let res = !idents in + idents := []; + List.map fst res let rev_let_bound_idents_with_loc bindings = idents := []; diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 132872a704..24439d113c 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -10,7 +10,13 @@ (* *) (***********************************************************************) -(* Abstract syntax tree after typing *) +(** Abstract syntax tree after typing *) + + +(** By comparison with {!Parsetree}: + - Every {!Longindent.t} is accompanied by a resolved {!Path.t}. + +*) open Asttypes open Types @@ -18,11 +24,14 @@ open Types (* Value expressions for the core language *) type partial = Partial | Total -type optional = Required | Optional + +(** {2 Extension points} *) type attribute = Parsetree.attribute type attributes = attribute list +(** {2 Core language} *) + type pattern = { pat_desc: pattern_desc; pat_loc: Location.t; @@ -34,24 +43,64 @@ type pattern = and pat_extra = | Tpat_constraint of core_type + (** P : T { pat_desc = P + ; pat_extra = (Tpat_constraint T, _, _) :: ... } + *) | Tpat_type of Path.t * Longident.t loc + (** #tconst { pat_desc = disjunction + ; pat_extra = (Tpat_type (P, "tconst"), _, _) :: ... } + + where [disjunction] is a [Tpat_or _] representing the + branches of [tconst]. + *) | Tpat_unpack + (** (module P) { pat_desc = Tpat_var "P" + ; pat_extra = (Tpat_unpack, _, _) :: ... } + *) and pattern_desc = Tpat_any + (** _ *) | Tpat_var of Ident.t * string loc + (** x *) | Tpat_alias of pattern * Ident.t * string loc + (** P as a *) | Tpat_constant of constant + (** 1, 'a', "true", 1.0, 1l, 1L, 1n *) | Tpat_tuple of pattern list + (** (P1, ..., Pn) + + Invariant: n >= 2 + *) | Tpat_construct of Longident.t loc * constructor_description * pattern list + (** C [] + C P [P] + C (P1, ..., Pn) [P1; ...; Pn] + *) | Tpat_variant of label * pattern option * row_desc ref + (** `A (None) + `A P (Some P) + + See {!Types.row_desc} for an explanation of the last parameter. + *) | Tpat_record of (Longident.t loc * label_description * pattern) list * closed_flag + (** { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) | Tpat_array of pattern list + (** [| P1; ...; Pn |] *) | Tpat_or of pattern * pattern * row_desc option + (** P1 | P2 + + [row_desc = Some _] when translating [Ppat_type _], [None] otherwise. + *) | Tpat_lazy of pattern + (** lazy P *) and expression = { exp_desc: expression_desc; @@ -64,22 +113,73 @@ and expression = and exp_extra = | Texp_constraint of core_type + (** E : T *) | Texp_coerce of core_type option * core_type + (** E :> T [Texp_coerce (None, T)] + E : T0 :> T [Texp_coerce (Some T0, T)] + *) | Texp_open of override_flag * Path.t * Longident.t loc * Env.t + (** let open[!] M in [Texp_open (!, P, M, env)] + where [env] is the environment after opening [P] + *) | Texp_poly of core_type option + (** Used for method bodies. *) | Texp_newtype of string + (** fun (type t) -> *) and expression_desc = Texp_ident of Path.t * Longident.t loc * Types.value_description + (** x + M.x + *) | Texp_constant of constant + (** 1, 'a', "true", 1.0, 1l, 1L, 1n *) | Texp_let of rec_flag * value_binding list * expression + (** let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) | Texp_function of arg_label * case list * partial - | Texp_apply of expression * (arg_label * expression option * optional) list + (** [Pexp_fun] and [Pexp_function] both translate to [Texp_function]. + See {!Parsetree} for more details. + + partial = + [Partial] if the pattern match is partial + [Total] otherwise. + *) + | Texp_apply of expression * (arg_label * expression option) list + (** E0 ~l1:E1 ... ~ln:En + + The expression can be None if the expression is abstracted over + this argument. It currently appears when a label is applied. + + For example: + let f x ~y = x + y in + f ~y:3 + + The resulting typedtree for the application is: + Texp_apply (Texp_ident "f/1037", + [(Nolabel, None); + (Labelled "y", Some (Texp_constant Const_int 3)) + ]) + *) | Texp_match of expression * case list * case list * partial + (** match E0 with + | P1 -> E1 + | P2 -> E2 + | exception P3 -> E3 + + [Texp_match (E0, [(P1, E1); (P2, E2)], [(P3, E3)], _)] + *) | Texp_try of expression * case list + (** try E with P1 -> E1 | ... | PN -> EN *) | Texp_tuple of expression list + (** (E1, ..., EN) *) | Texp_construct of Longident.t loc * constructor_description * expression list + (** C [] + C E [E] + C (E1, ..., En) [E1;...;En] + *) | Texp_variant of label * expression option | Texp_record of (Longident.t loc * label_description * expression) list * @@ -105,6 +205,7 @@ and expression_desc = | Texp_object of class_structure * string list | Texp_pack of module_expr | Texp_unreachable + | Texp_extension_constructor of Longident.t loc * Path.t and meth = Tmeth_name of string @@ -134,7 +235,7 @@ and class_expr_desc = | Tcl_fun of arg_label * pattern * (Ident.t * string loc * expression) list * class_expr * partial - | Tcl_apply of class_expr * (arg_label * expression option * optional) list + | Tcl_apply of class_expr * (arg_label * expression option) list | Tcl_let of rec_flag * value_binding list * (Ident.t * string loc * expression) list * class_expr | Tcl_constraint of @@ -181,9 +282,12 @@ and module_expr = mod_attributes: attributes; } +(** Annotations for [Tmod_constraint]. *) and module_type_constraint = - Tmodtype_implicit + | Tmodtype_implicit + (** The module type constraint has been synthesized during typecheking. *) | Tmodtype_explicit of module_type + (** The module type was in the source file. *) and module_expr_desc = Tmod_ident of Path.t * Longident.t loc @@ -192,6 +296,9 @@ and module_expr_desc = | Tmod_apply of module_expr * module_expr * module_coercion | Tmod_constraint of module_expr * Types.module_type * module_type_constraint * module_coercion + (** ME (constraint = Tmodtype_implicit) + (ME : MT) (constraint = Tmodtype_explicit MT) + *) | Tmod_unpack of expression * Types.module_type and structure = { @@ -342,9 +449,10 @@ and with_constraint = | Twith_modsubst of Path.t * Longident.t loc and core_type = -(* mutable because of [Typeclass.declare_method] *) { mutable ctyp_desc : core_type_desc; + (** mutable because of [Typeclass.declare_method] *) mutable ctyp_type : type_expr; + (** mutable because of [Typeclass.declare_method] *) ctyp_env : Env.t; (* BINANNOT ADDED *) ctyp_loc : Location.t; ctyp_attributes: attributes; @@ -520,10 +628,10 @@ val rev_let_bound_idents: value_binding list -> Ident.t list val let_bound_idents_with_loc: value_binding list -> (Ident.t * string loc) list -(* Alpha conversion of patterns *) +(** Alpha conversion of patterns *) val alpha_pat: (Ident.t * Ident.t) list -> pattern -> pattern val mknoloc: 'a -> 'a Asttypes.loc val mkloc: 'a -> Location.t -> 'a Asttypes.loc -val pat_bound_idents: pattern -> (Ident.t * string Asttypes.loc) list +val pat_bound_idents: pattern -> Ident.t list diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml index 3d22cbb2dc..419d67c709 100644 --- a/typing/typedtreeIter.ml +++ b/typing/typedtreeIter.ml @@ -270,7 +270,7 @@ module MakeIterator(Iter : IteratorArgument) : sig iter_cases cases | Texp_apply (exp, list) -> iter_expression exp; - List.iter (fun (label, expo, _) -> + List.iter (fun (label, expo) -> match expo with None -> () | Some exp -> iter_expression exp @@ -347,6 +347,8 @@ module MakeIterator(Iter : IteratorArgument) : sig iter_module_expr mexpr | Texp_unreachable -> () + | Texp_extension_constructor _ -> + () end; Iter.leave_expression exp; @@ -482,7 +484,7 @@ module MakeIterator(Iter : IteratorArgument) : sig | Tcl_apply (cl, args) -> iter_class_expr cl; - List.iter (fun (label, expo, _) -> + List.iter (fun (label, expo) -> match expo with None -> () | Some exp -> iter_expression exp diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml index 7d75301bee..6a4d8b4f8b 100644 --- a/typing/typedtreeMap.ml +++ b/typing/typedtreeMap.ml @@ -272,13 +272,13 @@ module MakeMap(Map : MapArgument) = struct Texp_function (label, map_cases cases, partial) | Texp_apply (exp, list) -> Texp_apply (map_expression exp, - List.map (fun (label, expo, optional) -> + List.map (fun (label, expo) -> let expo = match expo with None -> expo | Some exp -> Some (map_expression exp) in - (label, expo, optional) + (label, expo) ) list ) | Texp_match (exp, list1, list2, partial) -> Texp_match ( @@ -376,6 +376,8 @@ module MakeMap(Map : MapArgument) = struct Texp_pack (map_module_expr mexpr) | Texp_unreachable -> Texp_unreachable + | Texp_extension_constructor _ as e -> + e in let exp_extra = List.map map_exp_extra exp.exp_extra in Map.leave_expression { @@ -539,9 +541,8 @@ module MakeMap(Map : MapArgument) = struct | Tcl_apply (cl, args) -> Tcl_apply (map_class_expr cl, - List.map (fun (label, expo, optional) -> - (label, may_map map_expression expo, - optional) + List.map (fun (label, expo) -> + (label, may_map map_expression expo) ) args) | Tcl_let (rec_flat, bindings, ivars, cl) -> Tcl_let (rec_flat, map_bindings rec_flat bindings, diff --git a/typing/types.ml b/typing/types.ml index 3fca839376..f30d6ca5a9 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -19,7 +19,7 @@ open Asttypes type type_expr = { mutable desc: type_desc; mutable level: int; - mutable id: int } + id: int } and type_desc = Tvar of string option diff --git a/typing/types.mli b/typing/types.mli index 84131ccda1..f83e60a32a 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -10,32 +10,146 @@ (* *) (***********************************************************************) -(* Representation of types and declarations *) +(** {0 Representation of types and declarations} *) +(** [Types] defines the representation of types and declarations (that is, the + content of module signatures). + + CMI files are made of marshalled types. +*) + +(** Asttypes exposes basic definitions shared both by Parsetree and Types. *) open Asttypes -(* Type expressions for the core language *) +(** Type expressions for the core language. + + The [type_desc] variant defines all the possible type expressions one can + find in OCaml. [type_expr] wraps this with some annotations. + + The [level] field tracks the level of polymorphism associated to a type, + guiding the generalization algorithm. + Put shortly, when referring to a type in a given environment, both the type + and the environment have a level. If the type has an higher level, then it + can be considered fully polymorphic (type variables will be printed as + ['a]), otherwise it'll be weakly polymorphic, or non generalized (type + variables printed as ['_a]). + See [http://okmij.org/ftp/ML/generalization.html] for more information. + + Note about [type_declaration]: one should not make the confusion between + [type_expr] and [type_declaration]. + + [type_declaration] refers specifically to the [type] construct in OCaml + language, where you create and name a new type or type alias. + [type_expr] is used when you refer to existing types, e.g. when annotating + the expected type of a value. + + Also, as the type system of OCaml is generative, a [type_declaration] can + have the side-effect of introducing a new type constructor, different from + all other known types. + Whereas [type_expr] is a pure construct which allows referring to existing + types. + + Note on mutability: TBD. + *) type type_expr = { mutable desc: type_desc; mutable level: int; - mutable id: int } + id: int } and type_desc = - Tvar of string option + | Tvar of string option + (** [Tvar (Some "a")] ==> ['a] or ['_a] + [Tvar None] ==> [_] *) + | Tarrow of arg_label * type_expr * type_expr * commutable + (** [Tarrow (Nolabel, e1, e2, c)] ==> [e1 -> e2] + [Tarrow (Labelled "l", e1, e2, c)] ==> [l:e1 -> e2] + [Tarrow (Optional "l", e1, e2, c)] ==> [?l:e1 -> e2] + + See [commutable] for the last argument. *) + | Ttuple of type_expr list + (** [Ttuple [t1;...;tn]] ==> [(t1 * ... * tn)] *) + | Tconstr of Path.t * type_expr list * abbrev_memo ref + (** [Tconstr (`A.B.t', [t1;...;tn], _)] ==> [(t1,...,tn) A.B.t] + The last parameter keep tracks of known expansions, see [abbrev_memo]. *) + | Tobject of type_expr * (Path.t * type_expr list) option ref + (** [Tobject (`f1:t1;...;fn: tn', `None')] ==> [< f1: t1; ...; fn: tn >] + f1, fn are represented as a linked list of types using Tfield and Tnil + constructors. + + [Tobject (_, `Some (`A.ct', [t1;...;tn]')] ==> [(t1, ..., tn) A.ct]. + where A.ct is the type of some class. + + There are also special cases for so-called "class-types", cf. [Typeclass] + and [Ctype.set_object_name]: + + [Tobject (Tfield(_,_,…(Tfield(_,_,rv)…), Some(`A.#ct`, [rv;t1;…;tn])] + ==> [(t1, …, tn) #A.ct] + [Tobject (_, Some(`A.#ct`, [Tnil;t1;…;tn])] ==> [(t1, …, tn) A.ct] + + where [rv] is the hidden row variable. + *) + | Tfield of string * field_kind * type_expr * type_expr + (** [Tfield ("foo", Fpresent, t, ts)] ==> [<...; foo : t; ts>] *) + | Tnil + (** [Tnil] ==> [<...; >] *) + | Tlink of type_expr + (** Indirection used by unification engine. *) + | Tsubst of type_expr (* for copying *) + (** [Tsubst] is used temporarily to store information in low-level + functions manipulating representation of types, such as + instantiation or copy. + This constructor should not appear outside of these cases. *) + | Tvariant of row_desc + (** Representation of polymorphic variants, see [row_desc]. *) + | Tunivar of string option + (** Occurrence of a type variable introduced by a + forall quantifier / [Tpoly]. *) + | Tpoly of type_expr * type_expr list + (** [Tpoly (ty,tyl)] ==> ['a1... 'an. ty], + where 'a1 ... 'an are names given to types in tyl + and occurences of those types in ty. *) + | Tpackage of Path.t * Longident.t list * type_expr list + (** Type of a first-class module (a.k.a package). *) + +(** [ `X | `Y ] (row_closed = true) + [< `X | `Y ] (row_closed = true) + [> `X | `Y ] (row_closed = false) + [< `X | `Y > `X ] (row_closed = true) + + type t = [> `X ] as 'a (row_more = Tvar a) + type t = private [> `X ] (row_more = Tconstr (t#row, [], ref Mnil) + + And for: + + let f = function `X -> `X -> | `Y -> `X + + the type of "f" will be a [Tarrow] whose lhs will (basically) be: + + Tvariant { row_fields = [("X", _)]; + row_more = + Tvariant { row_fields = [("Y", _)]; + row_more = + Tvariant { row_fields = []; + row_more = _; + _ }; + _ }; + _ + } +*) and row_desc = { row_fields: (label * row_field) list; row_more: type_expr; @@ -52,16 +166,59 @@ and row_field = is erased later *) | Rabsent +(** [abbrev_memo] allows one to keep track of different expansions of a type + alias. This is done for performance purposes. + + For instance, when defining [type 'a pair = 'a * 'a], when one refers to an + ['a pair], it is just a shortcut for the ['a * 'a] type. + This expansion will be stored in the [abbrev_memo] of the corresponding + [Tconstr] node. + + In practice, [abbrev_memo] behaves like list of expansions with a mutable + tail. + + Note on marshalling: [abbrev_memo] must not appear in saved types. + [Btype], with [cleanup_abbrev] and [memo], takes care of tracking and + removing abbreviations. +*) and abbrev_memo = - Mnil + | Mnil (** No known abbrevation *) + | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo + (** Found one abbreviation. + A valid abbreviation should be at least as visible and reachable by the + same path. + The first expression is the abbreviation and the second the expansion. *) + | Mlink of abbrev_memo ref + (** Abbreviations can be found after this indirection *) and field_kind = Fvar of field_kind option ref | Fpresent | Fabsent +(** [commutable] is a flag appended to every arrow type. + + When typing an application, if the type of the functional is + known, its type is instantiated with [Cok] arrows, otherwise as + [Clink (ref Cunknown)]. + + When the type is not known, the application will be used to infer + the actual type. This is fragile in presence of labels where + there is no principal type. + + Two incompatible applications relying on [Cunknown] arrows will + trigger an error. + + let f g = + g ~a:() ~b:(); + g ~b:() ~a:(); + + Error: This function is applied to arguments + in an order different from other calls. + This is only allowed when the real type is known. +*) and commutable = Cok | Cunknown diff --git a/typing/untypeast.ml b/typing/untypeast.ml index e2587c7570..d2bdd28819 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -366,7 +366,7 @@ let expression sub exp = (sub.cases sub cases)) | Texp_apply (exp, list) -> Pexp_apply (sub.expr sub exp, - List.fold_right (fun (label, expo, _) list -> + List.fold_right (fun (label, expo) list -> match expo with None -> list | Some exp -> (label, sub.expr sub exp) :: list @@ -446,6 +446,11 @@ let expression sub exp = Pexp_pack (sub.module_expr sub mexpr) | Texp_unreachable -> Pexp_unreachable + | Texp_extension_constructor (lid, _) -> + Pexp_extension ({ txt = "ocaml.extension_constructor"; loc }, + PStr [ Str.eval ~loc + (Exp.construct ~loc (map_loc sub lid) None) + ]) in List.fold_right (exp_extra sub) exp.exp_extra (Exp.mk ~loc ~attrs desc) @@ -596,7 +601,7 @@ let class_expr sub cexpr = | Tcl_apply (cl, args) -> Pcl_apply (sub.class_expr sub cl, - List.fold_right (fun (label, expo, _) list -> + List.fold_right (fun (label, expo) list -> match expo with None -> list | Some exp -> (label, sub.expr sub exp) :: list diff --git a/utils/config.mlp b/utils/config.mlp index c668d13214..09f639cd86 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -57,7 +57,7 @@ and cmxa_magic_number = "Caml1999Z014" and ast_impl_magic_number = "Caml1999M019" and ast_intf_magic_number = "Caml1999N018" and cmxs_magic_number = "Caml2007D002" -and cmt_magic_number = "Caml2012T006" +and cmt_magic_number = "Caml2012T007" let load_path = ref ([] : string list) |