diff options
| author | Luc Maranget <luc.maranget@inria.fr> | 2009-08-21 08:39:33 +0000 |
|---|---|---|
| committer | Luc Maranget <luc.maranget@inria.fr> | 2009-08-21 08:39:33 +0000 |
| commit | 09213b3c2898c99401453a1d03a78989786708b7 (patch) | |
| tree | 0dd206f9f01d4657c8efbd35e21aa91b9b4187a4 | |
| parent | 91b60f2bba3e3973f8fc75d5ef9667a0c19b652a (diff) | |
| download | ocaml-09213b3c2898c99401453a1d03a78989786708b7.tar.gz | |
jo311merged
git-svn-id: http://caml.inria.fr/svn/ocaml/branches/jocamltrunk@9322 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
137 files changed, 1787 insertions, 1093 deletions
@@ -180,13 +180,15 @@ typing/oprint.cmo: typing/outcometree.cmi parsing/asttypes.cmi \ typing/oprint.cmx: typing/outcometree.cmi parsing/asttypes.cmi \ typing/oprint.cmi typing/parmatch.cmo: utils/warnings.cmi typing/types.cmi typing/typedtree.cmi \ - typing/predef.cmi typing/path.cmi utils/misc.cmi parsing/location.cmi \ - typing/ident.cmi typing/env.cmi typing/datarepr.cmi typing/ctype.cmi \ - typing/btype.cmi parsing/asttypes.cmi typing/parmatch.cmi + typing/subst.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \ + parsing/location.cmi typing/ident.cmi typing/env.cmi typing/datarepr.cmi \ + typing/ctype.cmi typing/btype.cmi parsing/asttypes.cmi \ + typing/parmatch.cmi typing/parmatch.cmx: utils/warnings.cmx typing/types.cmx typing/typedtree.cmx \ - typing/predef.cmx typing/path.cmx utils/misc.cmx parsing/location.cmx \ - typing/ident.cmx typing/env.cmx typing/datarepr.cmx typing/ctype.cmx \ - typing/btype.cmx parsing/asttypes.cmi typing/parmatch.cmi + typing/subst.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \ + parsing/location.cmx typing/ident.cmx typing/env.cmx typing/datarepr.cmx \ + typing/ctype.cmx typing/btype.cmx parsing/asttypes.cmi \ + typing/parmatch.cmi typing/path.cmo: typing/ident.cmi typing/path.cmi typing/path.cmx: typing/ident.cmx typing/path.cmi typing/predef.cmo: typing/types.cmi typing/path.cmi typing/ident.cmi \ @@ -311,7 +313,7 @@ bytecomp/bytesections.cmi: bytecomp/cmo_format.cmi: bytecomp/lambda.cmi typing/ident.cmi bytecomp/dll.cmi: bytecomp/emitcode.cmi: bytecomp/instruct.cmi bytecomp/cmo_format.cmi -bytecomp/instruct.cmi: typing/types.cmi parsing/location.cmi \ +bytecomp/instruct.cmi: typing/types.cmi typing/subst.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi bytecomp/lambda.cmi: typing/types.cmi typing/primitive.cmi typing/path.cmi \ parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi @@ -334,14 +336,14 @@ bytecomp/transljoin.cmi: typing/typedtree.cmi typing/primitive.cmi \ bytecomp/translmod.cmi: typing/typedtree.cmi typing/primitive.cmi \ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi bytecomp/translobj.cmi: bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi -bytecomp/typeopt.cmi: typing/types.cmi typing/typedtree.cmi typing/path.cmi \ - bytecomp/lambda.cmi typing/env.cmi -bytecomp/bytegen.cmo: typing/types.cmi bytecomp/switch.cmi typing/stypes.cmi \ - typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \ +bytecomp/typeopt.cmi: typing/typedtree.cmi typing/path.cmi \ + bytecomp/lambda.cmi +bytecomp/bytegen.cmo: typing/types.cmi bytecomp/switch.cmi typing/subst.cmi \ + typing/stypes.cmi typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \ bytecomp/instruct.cmi typing/ident.cmi utils/config.cmi \ parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi -bytecomp/bytegen.cmx: typing/types.cmx bytecomp/switch.cmx typing/stypes.cmx \ - typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx \ +bytecomp/bytegen.cmx: typing/types.cmx bytecomp/switch.cmx typing/subst.cmx \ + typing/stypes.cmx typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx \ bytecomp/instruct.cmx typing/ident.cmx utils/config.cmx \ parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi bytecomp/bytelibrarian.cmo: utils/misc.cmi utils/config.cmi \ @@ -361,15 +363,15 @@ bytecomp/bytelink.cmx: bytecomp/symtable.cmx bytecomp/opcodes.cmx \ utils/clflags.cmx utils/ccomp.cmx bytecomp/bytesections.cmx \ bytecomp/bytelink.cmi bytecomp/bytepackager.cmo: typing/typemod.cmi bytecomp/translmod.cmi \ - utils/misc.cmi bytecomp/instruct.cmi typing/ident.cmi typing/env.cmi \ - bytecomp/emitcode.cmi utils/config.cmi bytecomp/cmo_format.cmi \ - utils/clflags.cmi bytecomp/bytelink.cmi bytecomp/bytegen.cmi \ - bytecomp/bytepackager.cmi + typing/subst.cmi typing/path.cmi utils/misc.cmi bytecomp/instruct.cmi \ + typing/ident.cmi typing/env.cmi bytecomp/emitcode.cmi utils/config.cmi \ + bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytelink.cmi \ + bytecomp/bytegen.cmi bytecomp/bytepackager.cmi bytecomp/bytepackager.cmx: typing/typemod.cmx bytecomp/translmod.cmx \ - utils/misc.cmx bytecomp/instruct.cmx typing/ident.cmx typing/env.cmx \ - bytecomp/emitcode.cmx utils/config.cmx bytecomp/cmo_format.cmi \ - utils/clflags.cmx bytecomp/bytelink.cmx bytecomp/bytegen.cmx \ - bytecomp/bytepackager.cmi + typing/subst.cmx typing/path.cmx utils/misc.cmx bytecomp/instruct.cmx \ + typing/ident.cmx typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx \ + bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytelink.cmx \ + bytecomp/bytegen.cmx bytecomp/bytepackager.cmi bytecomp/bytesections.cmo: utils/config.cmi bytecomp/bytesections.cmi bytecomp/bytesections.cmx: utils/config.cmx bytecomp/bytesections.cmi bytecomp/dll.cmo: utils/misc.cmi utils/config.cmi bytecomp/dll.cmi @@ -384,9 +386,9 @@ bytecomp/emitcode.cmx: bytecomp/translmod.cmx typing/primitive.cmx \ bytecomp/instruct.cmx typing/env.cmx utils/config.cmx \ bytecomp/cmo_format.cmi utils/clflags.cmx typing/btype.cmx \ parsing/asttypes.cmi bytecomp/emitcode.cmi -bytecomp/instruct.cmo: typing/types.cmi parsing/location.cmi \ +bytecomp/instruct.cmo: typing/types.cmi typing/subst.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi bytecomp/instruct.cmi -bytecomp/instruct.cmx: typing/types.cmx parsing/location.cmx \ +bytecomp/instruct.cmx: typing/types.cmx typing/subst.cmx parsing/location.cmx \ bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx bytecomp/instruct.cmi bytecomp/lambda.cmo: typing/types.cmi typing/primitive.cmi typing/path.cmi \ utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \ @@ -1,3 +1,58 @@ +Objective Caml 3.11.1: +---------------------- + +Bug fixes: +- PR#4095: ocamldebug: strange behaviour of control-C +- PR#4403: ocamldebug: improved handling of packed modules +- PR#4650: Str.regexp_case_fold mis-handling complemented character sets [^a] +- PR#4660: Scanf.format_from_string: handling of double quote +- PR#4666: Unix.exec* failure in multithread programs under MacOS X and FreeBSD +- PR#4667: debugger out of sync with dynlink changes +- PR#4678: random "out of memory" error with systhreads +- PR#4690: issue with dynamic loading under MacOS 10.5 +- PR#4692: wrong error message with options -i and -pack passed to ocamlc +- PR#4699: in otherlibs/dbm, fixed construction of dlldbm.so. +- PR#4704: error in caml_modify_generational_global_root() +- PR#4708: (ocamldoc) improved printing of infix identifiers such as "lor". +- PR#4722: typo in configure script +- PR#4729: documented the fact that PF_INET6 is not available on all platforms +- PR#4730: incorrect typing involving abbreviation "type 'a t = 'a" +- PR#4731: incorrect quoting of arguments passed to the assembler on x86-64 +- PR#4735: Unix.LargeFile.fstat cannot report size over 32bits on Win32 +- PR#4740: guard against possible processor error in + {Int32,Int64,Nativeint}.{div,rem} +- PR#4745: type inference wrongly produced non-generalizable type variables. +- PR#4749: better pipe size for win32unix +- PR#4756: printf: no error reported for wrong format '%_s' +- PR#4758: scanf: handling of \<newline> by format '%S' +- PR#4766: incorrect simplification of some type abbreviations. +- PR#4768: printf: %F does not respect width and precision specifications +- PR#4769: Format.bprintf fails to flush +- PR#4775: fatal error Ctype.Unify during module type-checking (temporary fix) +- PR#4776: bad interaction between exceptions and classes +- PR#4780: labltk build problem under Windows. +- PR#4790: under Windows, map ERROR_NO_DATA Win32 error to EPIPE Unix error. +- PR#4792: bug in Big_int.big_int_of_int64 on 32-bit platforms. +- PR#4796: ocamlyacc: missing NUL termination of string +- PR#4804: bug in Big_int.int64_of_big_int on 32-bit platforms. +- PR#4805: improving compatibility with the clang C compiler +- PR#4809: issue with Unix.create_process under Win32 +- PR#4814: ocamlbrowser: crash when editing comments +- PR#4816: module abbreviations remove 'private' type restrictions +- PR#4817: Object type gives error "Unbound type parameter .." +- Module Parsing: improved computation of locations when an ocamlyacc rule + starts with an empty nonterminal +- Type-checker: fixed wrong variance computation for private types +- x86-32 code generator, MSVC port: wrong "fld" instruction generated. +- ocamlbuild: incorrectly using the compile-time value of $OCAMLLIB +- Makefile problem when configured with -no-shared-libs +- ocamldoc: use dynamic loading in native code + +Other changes: +- Improved wording of various error messages + (contributed by Jonathan Davies, Citrix). +- Support for 64-bit mode in Solaris/x86 (PR#4670). + Objective Caml 3.11.0: ---------------------- @@ -8,17 +63,21 @@ Language features: after forcing, match the pattern <pat>. - Introduction of private abbreviation types "type t = private <type-expr>", for abstracting the actual manifest type in type abbreviations. +- Subtyping is now allowed between a private abbreviation and its definition, + and between a polymorphic method and its monomorphic instance. Compilers: -* The file name for a compilation unit must correspond to a valid identifier - (no more "test-me.ml" or "my file.ml".) +- The file name for a compilation unit should correspond to a valid + identifier (Otherwise dynamic linking and other things can fail, and + a warning is emitted.) * Revised -output-obj: the output name must now be provided; its extension must be one of .o/.obj, .so/.dll, or .c for the bytecode compiler. The compilers can now produce a shared library (with all the needed -ccopts/-ccobjs options) directly. -- With -dtypes, record (in .annot files) which function calls +- -dtypes renamed to -annot, records (in .annot files) which function calls are tail calls. -- All compiler error messages now include a file name and location. +- All compiler error messages now include a file name and location, for + better interaction with Emacs' compilation mode. - Optimized compilation of "lazy e" when the argument "e" is already evaluated. - Optimized compilation of equality tests with a variant constant constructor. @@ -32,17 +91,17 @@ Compilers: float fields). Native-code compiler: +- New port: Mac OS X / Intel in 64-bit mode (configure with -cc "gcc -m64"). - A new option "-shared" to produce a plugin that can be dynamically loaded with the native version of Dynlink. - A new option "-nodynlink" to enable optimizations valid only for code that is never dynlinked (no-op except for AMD64). - More aggressive unboxing of floats and boxed integers. -- Can select with assembler and asm options to use at configuration time. +- Can select which assembler and asm options to use at configuration time. Run-time system: -- Changes in freelist management to reduce fragmentation. -- New implementation of the page table describing the heap (a sparse - hashtable replaces a dense bitvector), fixes issues with address +- New implementation of the page table describing the heap (two-level + array in 32 bits, sparse hashtable in 64 bits), fixes issues with address space randomization on 64-bit OS (PR#4448). - New "generational" API for registering global memory roots with the GC, enables faster scanning of global roots. @@ -52,6 +111,9 @@ Run-time system: - Changes in implementation of dynamic linking of C code: under Win32, use Alain Frisch's flexdll implementation of the dlopen API; under MacOSX, use dlopen API instead of MacOSX bundle API. +- Programs may now choose a first-fit allocation policy instead of + the default next-fit. First-fit reduces fragmentation but is + slightly slower in some cases. Standard library: - Parsing library: new function "set_trace" to programmatically turn @@ -60,7 +122,7 @@ Standard library: to obtain a stack backtrace of the most recently raised exception. New function "record_backtrace" to turn the exception backtrace mechanism on or off from within a program. -- Scanf library: debunking of meta format implementation; +- Scanf library: fine-tuning of meta format implementation; fscanf behaviour revisited: only one input buffer is allocated for any given input channel; the %n conversion does not count a lookahead character as read. @@ -83,18 +145,21 @@ Other libraries: Tools: - ocamldebug now supported under Windows (MSVC and Mingw ports), - but without the replay feature. (Contributed by Sylvain Le Gall - at OCamlCore with support from Lexifi.) + but without the replay feature. (Contributed by Dmitry Bely + and Sylvain Le Gall at OCamlCore with support from Lexifi.) - ocamldoc: new option -no-module-constraint-filter to include functions hidden by signature constraint in documentation. - ocamlmklib and ocamldep.opt now available under Windows ports. - ocamlmklib no longer supports the -implib option. - ocamlnat: an experimental native toplevel (not built by default). +Camlp4: +* programs linked with camlp4lib.cma now also need dynlink.cma. + Bug fixes: - Major GC and heap compaction: fixed bug involving lazy values and out-of-heap pointers. -- PR#3915: updated some man pages. +- PR#3915: updated most man pages. - PR#4261: type-checking of recursive modules - PR#4308: better stack backtraces for "spontaneous" exceptions such as Stack_overflow, Out_of_memory, etc. @@ -109,12 +174,13 @@ Bug fixes: - PR#4564: add note "stack is not executable" to object files generated by ocamlopt (Linux/x86, Linux/AMD64). - PR#4566: bug in Ratio.approx_ratio_fix and Num.approx_num_fix. -- PR#4582: weird behaviour of String.index_from and String.rindex_from. +- PR#4582: clarified the documentation of functions in the String module. - PR#4583: stack overflow in "ocamlopt -g" during closure conversion pass. - PR#4585: ocamldoc and "val virtual" declarations. - PR#4587: ocamldoc and escaped @ characters. -- PR#4605: Buffer.add_substitute was sometime wrong when target string had backslashes. -- PR#4614: Inconsistent declaration of CamlCBCmd in LabelTk library. +- PR#4605: Buffer.add_substitute was sometime wrong when target string had + backslashes. +- PR#4614: Inconsistent declaration of CamlCBCmd in LablTk library. Objective Caml 3.10.2: diff --git a/Changes_JoCaml b/Changes_JoCaml index 903ff294c6..069f77fd10 100644 --- a/Changes_JoCaml +++ b/Changes_JoCaml @@ -1,3 +1,9 @@ +JoCaml 3.11.1 + +- Corrected bug in installation (all tools now installed with 'jo' prefix) + +JoCaml 3.11.0: +------------- - Several alteration of scheduling, so as to limit pending signals, <= threads in pool and <= tasks in pool. @@ -10,14 +10,10 @@ CONTEXT Caml installation. -PREREQUISITES - * They are the same as the ones of Objective Caml, * plus: the POSIX threads library 'phreads' is required. -INSTALLATION INSTRUCTION - 1- Configure the system. From the top directory, do: diff --git a/INSTALL_OCAML b/INSTALL_OCAML index c1d8457086..cdb3436fbd 100644 --- a/INSTALL_OCAML +++ b/INSTALL_OCAML @@ -5,11 +5,13 @@ PREREQUISITES * The GNU C compiler gcc is recommended, as the bytecode interpreter takes advantage of gcc-specific features to enhance - performance. + performance. gcc is the standard compiler under Linux, MacOS X, + and many other systems. -* Under HP/UX, the GNU C compiler gcc, the GNU assembler gas, and GNU make - are all *required*. The vendor-provided compiler, assembler and make - have major problems. +* Under MacOS X 10.5, you need version 3.1 or later of the XCode + development tools. The version of XCode found on MacOS X 10.5 + installation media causes linking problems. XCode updates + are available free of charge at http://developer.apple.com/tools/xcode/ * Under MacOS X up to version 10.2.8, you must raise the limit on the stack size with one of the following commands: @@ -20,6 +22,10 @@ PREREQUISITES * If you do not have write access to /tmp, you should set the environment variable TMPDIR to the name of some other temporary directory. +* Under HP/UX, the GNU C compiler gcc, the GNU assembler gas, and GNU make + are all *required*. The vendor-provided compiler, assembler and make + have major problems. + INSTALLATION INSTRUCTIONS @@ -120,7 +126,8 @@ Examples: Installation in /usr, man pages in section "l": ./configure -bindir /usr/bin -libdir /usr/lib/ocaml -mandir /usr/man/manl - On a MacOSX/PowerPC host, to build a 64-bit version of OCaml: + On a MacOSX/Intel Core 2 or MacOSX/PowerPC host, to build a 64-bit version + of OCaml: ./configure -cc "gcc -m64" On a Linux x86/64 bits host, to build a 32-bit version of OCaml: @@ -290,7 +290,7 @@ install: cp toplevel/toploop.cmi toplevel/topdirs.cmi toplevel/topmain.cmi \ $(LIBDIR) cd tools; $(MAKE) install -# -cd man; $(MAKE) install +# -$(MAKE) -C man install for i in $(OTHERLIBRARIES); do \ (cd otherlibs/$$i; $(MAKE) install) || exit $$?; \ done @@ -700,15 +700,9 @@ ocamldebugger: # Camlp4 camlp4out camlp4opt camlp4optopt: - -#camlp4out: ocamlc otherlibraries ocamlbuild-partial-boot ocamlbuild.byte -# ./build/camlp4-byte-only.sh -# -#camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-partial-boot ocamlbuild.native -# ./build/camlp4-native-only.sh +camlp4opt: # Ocamlbuild -ocamlbuild.byte ocamlbuild.native: #ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-partial-boot # ./build/ocamlbuild-byte-only.sh # @@ -761,14 +755,8 @@ clean:: $(CAMLOPT) $(COMPFLAGS) -c $< partialclean:: - rm -f utils/*.cm[iox] utils/*.[so] utils/*~ - rm -f parsing/*.cm[iox] parsing/*.[so] parsing/*~ - rm -f typing/*.cm[iox] typing/*.[so] typing/*~ - rm -f bytecomp/*.cm[iox] bytecomp/*.[so] bytecomp/*~ - rm -f asmcomp/*.cm[iox] asmcomp/*.[so] asmcomp/*~ - rm -f driver/*.cm[iox] driver/*.[so] driver/*~ - rm -f toplevel/*.cm[iox] toplevel/*.[so] toplevel/*~ - rm -f tools/*.cm[iox] tools/*.[so] tools/*~ + for d in utils parsing typing bytecomp asmcomp driver toplevel tools; \ + do rm -f $$d/*.cm[iox] $$d/*.annot $$d/*.[so] $$d/*~; done rm -f *~ depend: beforedepend @@ -785,7 +773,7 @@ distclean: .PHONY: partialclean beforedepend alldepend cleanboot coldstart .PHONY: compare core coreall .PHONY: coreboot defaultentry depend distclean install installopt -.PHONY: library library-cross libraryopt ocamlbuild-partial-boot +.PHONY: library library-cross libraryopt ocamlbuild-mixed-boot .PHONY: ocamlbuild.byte ocamlbuild.native ocamldebugger ocamldoc .PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltools.opt .PHONY: ocamlyacc opt-core opt opt.opt otherlibraries diff --git a/Makefile.nt b/Makefile.nt index 855274bed7..fe4199b770 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -594,24 +594,24 @@ alldepend:: # Camlp4 -camlp4out: ocamlc otherlibraries ocamlbuild-partial-boot ocamlbuild.byte +camlp4out: ocamlc otherlibraries ocamlbuild-mixed-boot ocamlbuild.byte ./build/camlp4-byte-only.sh -camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-partial-boot ocamlbuild.native +camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ocamlbuild.native ./build/camlp4-native-only.sh # Ocamlbuild -ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-partial-boot +ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-mixed-boot ./build/ocamlbuild-byte-only.sh -ocamlbuild.native: ocamlopt otherlibrariesopt ocamlbuild-partial-boot +ocamlbuild.native: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ./build/ocamlbuild-native-only.sh -ocamlbuildlib.native: ocamlopt otherlibrariesopt ocamlbuild-partial-boot +ocamlbuildlib.native: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ./build/ocamlbuildlib-native-only.sh -.PHONY: ocamlbuild-partial-boot -ocamlbuild-partial-boot: - ./build/partial-boot.sh +.PHONY: ocamlbuild-mixed-boot +ocamlbuild-mixed-boot: + ./build/mixed-boot.sh partialclean:: rm -rf _build @@ -33,8 +33,8 @@ CONTENTS: COPYRIGHT: All files marked "Copyright INRIA" in this distribution are copyright -1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006 2007 -Institut National de Recherche en Informatique et en Automatique +1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +2007, 2008 Institut National de Recherche en Informatique et en Automatique (INRIA) and distributed under the conditions stated in file LICENSE. INSTALLATION: diff --git a/README_OCAML b/README_OCAML index 50e417ece1..e82420df26 100644 --- a/README_OCAML +++ b/README_OCAML @@ -78,8 +78,8 @@ CONTENTS: COPYRIGHT: All files marked "Copyright INRIA" in this distribution are copyright -1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006 -Institut National de Recherche en Informatique et en Automatique +1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +2007, 2008 Institut National de Recherche en Informatique et en Automatique (INRIA) and distributed under the conditions stated in file LICENSE. INSTALLATION: @@ -1,4 +1,4 @@ -3.11+dev19 Private_abbrevs+natdynlink+lazy_patterns+fscanf debug (2008-10-06) +3.12.0+dev0 # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli @@ -26,14 +26,13 @@ true: use_stdlib <ocamldoc/**>: -debug <ocamldoc/*.ml>: ocamldoc_sources <ocamldoc/*.ml*>: include_unix, include_str, include_dynlink -"ocamldoc/odoc.byte": use_unix, use_str, use_dynlink -"ocamldoc/odoc_opt.native": use_unix, use_str +<ocamldoc/odoc.{byte,native}>: use_unix, use_str, use_dynlink <camlp4/**/*.ml*>: camlp4boot, -warn_Alez, warn_Ale <camlp4/Camlp4_{config,import}.ml*>: -camlp4boot "camlp4/Camlp4_import.ml": -warn_Ale <camlp4/build/*> or <camlp4/boot/*> or "camlp4/Camlp4/Struct/Lexer.ml": -camlp4boot, -warn_Ale, warn_a -<camlp4/Camlp4Bin.{byte,native}> or "camlp4/camlp4lib.cma" or <camlp4/{mkcamlp4,boot/camlp4boot}.byte>: use_dynlink +<camlp4/Camlp4Bin.{byte,native}> or <camlp4/{mkcamlp4,boot/camlp4boot}.byte>: use_dynlink "camlp4/Camlp4/Printers/OCaml.ml" or "camlp4/Camlp4/Printers/OCamlr.ml": warn_Alezv <camlp4/Camlp4Printers/**.ml>: include_unix "camlp4/Camlp4/Struct/DynLoader.ml" or "camlp4/boot/Camlp4.ml": include_dynlink diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index c38a73e8c2..e2a53465e5 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -23,6 +23,12 @@ open Mach open Linearize open Emitaux +let macosx = + match Config.system with + | "macosx" -> true + | _ -> false + + (* Tradeoff between code size and code speed *) let fastcode_flag = ref true @@ -54,15 +60,16 @@ let slot_offset loc cl = (* Symbols *) let emit_symbol s = - Emitaux.emit_symbol '$' s + if macosx then emit_string "_"; + Emitaux.emit_symbol '$' s let emit_call s = - if !Clflags.dlcode + if !Clflags.dlcode && not macosx then `call {emit_symbol s}@PLT` else `call {emit_symbol s}` let emit_jump s = - if !Clflags.dlcode + if !Clflags.dlcode && not macosx then `jmp {emit_symbol s}@PLT` else `jmp {emit_symbol s}` @@ -82,6 +89,7 @@ let emit_label lbl = (* Output a .align directive. *) let emit_align n = + let n = if macosx then Misc.log2 n else n in ` .align {emit_int n}\n` let emit_Llabel fallthrough lbl = @@ -588,7 +596,9 @@ let emit_instr fallthrough i = end else begin ` jmp *{emit_label lbl}(, {emit_reg i.arg.(0)}, 8)\n` end; - ` .section .rodata\n`; + if macosx + then ` .const\n` + else ` .section .rodata\n`; emit_align 8; `{emit_label lbl}:`; for i = 0 to Array.length jumptbl - 1 do @@ -658,7 +668,11 @@ let fundecl fundecl = bound_error_call := 0; ` .text\n`; emit_align 16; - ` .globl {emit_symbol fundecl.fun_name}\n`; + if macosx && is_generic_function fundecl.fun_name + then (* PR#4690 *) + ` .private_extern {emit_symbol fundecl.fun_name}\n` + else + ` .globl {emit_symbol fundecl.fun_name}\n`; `{emit_symbol fundecl.fun_name}:\n`; if !Clflags.gprofile then emit_profile(); if frame_required() then begin @@ -670,9 +684,16 @@ let fundecl fundecl = List.iter emit_call_gc !call_gc_sites; emit_call_bound_errors (); if !float_constants <> [] then begin - ` .section .rodata.cst8,\"a\",@progbits\n`; + if macosx + then ` .literal8\n` + else ` .section .rodata.cst8,\"a\",@progbits\n`; List.iter emit_float_constant !float_constants - end + end; + match Config.system with + "linux" | "gnu" -> + ` .type {emit_symbol fundecl.fun_name},@function\n`; + ` .size {emit_symbol fundecl.fun_name},.-{emit_symbol fundecl.fun_name}\n` + | _ -> () (* Emission of data *) @@ -715,11 +736,19 @@ let data l = let begin_assembly() = if !Clflags.dlcode then begin (* from amd64.S; could emit these constants on demand *) - ` .section .rodata.cst8,\"a\",@progbits\n`; - ` .align 16\n`; - `caml_negf_mask: .quad 0x8000000000000000, 0\n`; - ` .align 16\n`; - `caml_absf_mask: .quad 0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF\n`; + if macosx then begin + ` .literal16\n`; + ` .align 4\n`; + `caml_negf_mask: .quad 0x8000000000000000, 0\n`; + ` .align 4\n`; + `caml_absf_mask: .quad 0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF\n`; + end else begin + ` .section .rodata.cst8,\"a\",@progbits\n`; + ` .align 16\n`; + `caml_negf_mask: .quad 0x8000000000000000, 0\n`; + ` .align 16\n`; + `caml_absf_mask: .quad 0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF\n`; + end; end; let lbl_begin = Compilenv.make_symbol (Some "data_begin") in ` .data\n`; @@ -728,11 +757,13 @@ let begin_assembly() = let lbl_begin = Compilenv.make_symbol (Some "code_begin") in ` .text\n`; ` .globl {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin}:\n` + `{emit_symbol lbl_begin}:\n`; + if macosx then ` nop\n` (* PR#4690 *) let end_assembly() = let lbl_end = Compilenv.make_symbol (Some "code_end") in ` .text\n`; + if macosx then ` nop\n`; (* suppress "ld warning: atom sorting error" *) ` .globl {emit_symbol lbl_end}\n`; `{emit_symbol lbl_end}:\n`; ` .data\n`; @@ -749,8 +780,17 @@ let end_assembly() = efa_32 = (fun n -> ` .long {emit_int32 n}\n`); efa_word = (fun n -> ` .quad {emit_int n}\n`); efa_align = emit_align; - efa_label_rel = (fun lbl ofs -> - ` .long ({emit_label lbl} - .) + {emit_int32 ofs}\n`); + efa_label_rel = + if macosx then begin + let setcnt = ref 0 in + fun lbl ofs -> + incr setcnt; + ` .set L$set${emit_int !setcnt}, ({emit_label lbl} - .) + {emit_int32 ofs}\n`; + ` .long L$set${emit_int !setcnt}\n` + end else begin + fun lbl ofs -> + ` .long ({emit_label lbl} - .) + {emit_int32 ofs}\n` + end; efa_def_label = (fun l -> `{emit_label l}:\n`); efa_string = (fun s -> emit_string_directive " .asciz " s) }; if Config.system = "linux" then diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml index 32d669dbbe..da2f886bbc 100644 --- a/asmcomp/amd64/proc.ml +++ b/asmcomp/amd64/proc.ml @@ -197,5 +197,5 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - Ccomp.command (Config.asm ^ " -o " ^ outfile ^ " " ^ infile) - + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml index 6ee3ee160d..26955f4099 100644 --- a/asmcomp/amd64/selection.ml +++ b/asmcomp/amd64/selection.ml @@ -122,17 +122,21 @@ method is_immediate n = n <= 0x7FFFFFFF && n >= -0x80000000 method is_immediate_natint n = n <= 0x7FFFFFFFn && n >= -0x80000000n method select_addressing exp = - match select_addr exp with - (Asymbol s, d) -> - (Ibased(s, d), Ctuple []) - | (Alinear e, d) -> - (Iindexed d, e) - | (Aadd(e1, e2), d) -> - (Iindexed2 d, Ctuple[e1; e2]) - | (Ascale(e, scale), d) -> - (Iscaled(scale, d), e) - | (Ascaledadd(e1, e2, scale), d) -> - (Iindexed2scaled(scale, d), Ctuple[e1; e2]) + let (a, d) = select_addr exp in + (* PR#4625: displacement must be a signed 32-bit immediate *) + if d < -0x8000_0000 || d > 0x7FFF_FFFF + then (Iindexed 0, exp) + else match a with + | Asymbol s -> + (Ibased(s, d), Ctuple []) + | Alinear e -> + (Iindexed d, e) + | Aadd(e1, e2) -> + (Iindexed2 d, Ctuple[e1; e2]) + | Ascale(e, scale) -> + (Iscaled(scale, d), e) + | Ascaledadd(e1, e2, scale) -> + (Iindexed2scaled(scale, d), Ctuple[e1; e2]) method select_store addr exp = match exp with diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 83cb1f6e39..00742dcf99 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -1943,9 +1943,8 @@ module IntSet = Set.Make( end) let default_apply = IntSet.add 2 (IntSet.add 3 IntSet.empty) - (* These apply funs are always present in the main program. - TODO: add more, and do the same for send and curry funs - (maybe up to 10-15?). *) + (* These apply funs are always present in the main program because + the run-time system needs them (cf. asmrun/<arch>.S) . *) let generic_functions shared units = let (apply,send,curry) = @@ -1955,12 +1954,8 @@ let generic_functions shared units = List.fold_right IntSet.add ui.Compilenv.ui_send_fun send, List.fold_right IntSet.add ui.Compilenv.ui_curry_fun curry) (IntSet.empty,IntSet.empty,IntSet.empty) - units - in - let apply = - if shared then IntSet.diff apply default_apply - else IntSet.union apply default_apply - in + units in + let apply = if shared then apply else IntSet.union apply default_apply in let accu = IntSet.fold (fun n accu -> apply_function n :: accu) apply [] in let accu = IntSet.fold (fun n accu -> send_function n :: accu) send accu in IntSet.fold (fun n accu -> curry_function n @ accu) curry accu diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml index d1964d3563..e851c8187d 100644 --- a/asmcomp/emitaux.ml +++ b/asmcomp/emitaux.ml @@ -156,3 +156,16 @@ let emit_frames a = List.iter emit_frame !frame_descriptors; Hashtbl.iter emit_filename filenames; frame_descriptors := [] + +(* Detection of functions that can be duplicated between a DLL and + the main program (PR#4690) *) + +let isprefix s1 s2 = + String.length s1 <= String.length s2 + && String.sub s2 0 (String.length s1) = s1 + +let is_generic_function name = + List.exists + (fun p -> isprefix p name) + ["caml_apply"; "caml_curry"; "caml_send"; "caml_tuplify"] + diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli index 38e6df9607..112e276a12 100644 --- a/asmcomp/emitaux.mli +++ b/asmcomp/emitaux.mli @@ -45,3 +45,5 @@ type emit_frame_actions = efa_string: string -> unit } val emit_frames: emit_frame_actions -> unit + +val is_generic_function: string -> bool diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index aaaba421a4..89d6a156d7 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -875,15 +875,6 @@ let emit_profile () = ` popl %eax\n` | _ -> () (*unsupported yet*) -(* Declare a global function symbol *) - -let declare_function_symbol name = - ` .globl {emit_symbol name}\n`; - match Config.system with - "linux_elf" | "bsd_elf" | "gnu" -> - ` .type {emit_symbol name},@function\n` - | _ -> () - (* Emission of a function declaration *) let fundecl fundecl = @@ -897,7 +888,11 @@ let fundecl fundecl = bound_error_call := 0; ` .text\n`; emit_align 16; - declare_function_symbol fundecl.fun_name; + if macosx && is_generic_function fundecl.fun_name + then (* PR#4690 *) + ` .private_extern {emit_symbol fundecl.fun_name}\n` + else + ` .globl {emit_symbol fundecl.fun_name}\n`; `{emit_symbol fundecl.fun_name}:\n`; if !Clflags.gprofile then emit_profile(); let n = frame_size() - 4 in @@ -907,7 +902,13 @@ let fundecl fundecl = emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; emit_call_bound_errors (); - List.iter emit_float_constant !float_constants + List.iter emit_float_constant !float_constants; + match Config.system with + "linux_elf" | "bsd_elf" | "gnu" -> + ` .type {emit_symbol fundecl.fun_name},@function\n`; + ` .size {emit_symbol fundecl.fun_name},.-{emit_symbol fundecl.fun_name}\n` + | _ -> () + (* Emission of data *) @@ -957,11 +958,13 @@ let begin_assembly() = let lbl_begin = Compilenv.make_symbol (Some "code_begin") in ` .text\n`; ` .globl {emit_symbol lbl_begin}\n`; - `{emit_symbol lbl_begin}:\n` + `{emit_symbol lbl_begin}:\n`; + if macosx then ` nop\n` (* PR#4690 *) let end_assembly() = let lbl_end = Compilenv.make_symbol (Some "code_end") in ` .text\n`; + if macosx then ` nop\n`; (* suppress "ld warning: atom sorting error" *) ` .globl {emit_symbol lbl_end}\n`; `{emit_symbol lbl_end}:\n`; ` .data\n`; diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp index e4ac9d408d..a0c94e181d 100644 --- a/asmcomp/i386/emit_nt.mlp +++ b/asmcomp/i386/emit_nt.mlp @@ -379,7 +379,7 @@ let emit_instr i = if is_tos src then ` fstp {emit_reg dst}\n` else if is_tos dst then - ` fld {emit_reg dst}\n` + ` fld {emit_reg src}\n` else begin ` fld {emit_reg src}\n`; ` fstp {emit_reg dst}\n` diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index d25eaa3478..4df559f684 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -835,6 +835,10 @@ let fundecl fundecl = call_gc_label := 0; float_literals := []; int_literals := []; + if Config.system = "rhapsody" && is_generic_function fundecl.fun_name + then (* PR#4690 *) + ` .private_extern {emit_symbol fundecl.fun_name}\n` + else ` .globl {emit_symbol fundecl.fun_name}\n`; begin match Config.system with | "elf" | "bsd" -> diff --git a/asmrun/.depend b/asmrun/.depend index 916da83ee9..6b66a0c3a7 100644 --- a/asmrun/.depend +++ b/asmrun/.depend @@ -16,9 +16,10 @@ array.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h -backtrace.o: backtrace.c ../byterun/backtrace.h ../byterun/mlvalues.h \ +backtrace.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/backtrace.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ @@ -139,7 +140,9 @@ globroots.o: globroots.c ../byterun/memory.h ../byterun/config.h \ ../byterun/config.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/globroots.h ../byterun/mlvalues.h + ../byterun/mlvalues.h ../byterun/roots.h ../byterun/misc.h \ + ../byterun/memory.h ../byterun/globroots.h ../byterun/mlvalues.h \ + ../byterun/roots.h hash.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/config.h ../byterun/custom.h ../byterun/mlvalues.h \ @@ -306,7 +309,7 @@ roots.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/globroots.h ../byterun/mlvalues.h \ - stack.h + ../byterun/roots.h stack.h signals.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ @@ -334,14 +337,14 @@ startup.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/config.h ../byterun/backtrace.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/gc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/config.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/osdeps.h ../byterun/misc.h \ - ../byterun/printexc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/sys.h ../byterun/misc.h natdynlink.h + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ + ../byterun/misc.h ../byterun/printexc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/sys.h ../byterun/misc.h natdynlink.h str.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ @@ -401,9 +404,10 @@ array.d.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h -backtrace.d.o: backtrace.c ../byterun/backtrace.h ../byterun/mlvalues.h \ +backtrace.d.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/backtrace.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ @@ -524,7 +528,9 @@ globroots.d.o: globroots.c ../byterun/memory.h ../byterun/config.h \ ../byterun/config.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/globroots.h ../byterun/mlvalues.h + ../byterun/mlvalues.h ../byterun/roots.h ../byterun/misc.h \ + ../byterun/memory.h ../byterun/globroots.h ../byterun/mlvalues.h \ + ../byterun/roots.h hash.d.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/config.h ../byterun/custom.h ../byterun/mlvalues.h \ @@ -691,7 +697,7 @@ roots.d.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/globroots.h ../byterun/mlvalues.h \ - stack.h + ../byterun/roots.h stack.h signals.d.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ @@ -719,14 +725,14 @@ startup.d.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/config.h ../byterun/backtrace.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/gc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/config.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/osdeps.h ../byterun/misc.h \ - ../byterun/printexc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/sys.h ../byterun/misc.h natdynlink.h + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ + ../byterun/misc.h ../byterun/printexc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/sys.h ../byterun/misc.h natdynlink.h str.d.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ @@ -786,9 +792,10 @@ array.p.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h -backtrace.p.o: backtrace.c ../byterun/backtrace.h ../byterun/mlvalues.h \ +backtrace.p.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/backtrace.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ @@ -909,7 +916,9 @@ globroots.p.o: globroots.c ../byterun/memory.h ../byterun/config.h \ ../byterun/config.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/globroots.h ../byterun/mlvalues.h + ../byterun/mlvalues.h ../byterun/roots.h ../byterun/misc.h \ + ../byterun/memory.h ../byterun/globroots.h ../byterun/mlvalues.h \ + ../byterun/roots.h hash.p.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/config.h ../byterun/custom.h ../byterun/mlvalues.h \ @@ -1076,7 +1085,7 @@ roots.p.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/globroots.h ../byterun/mlvalues.h \ - stack.h + ../byterun/roots.h stack.h signals.p.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ @@ -1104,14 +1113,14 @@ startup.p.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/misc.h ../byterun/config.h ../byterun/backtrace.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ ../byterun/gc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/config.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ - ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/osdeps.h ../byterun/misc.h \ - ../byterun/printexc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/sys.h ../byterun/misc.h natdynlink.h + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ + ../byterun/misc.h ../byterun/printexc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/sys.h ../byterun/misc.h natdynlink.h str.p.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ diff --git a/asmrun/amd64.S b/asmrun/amd64.S index 4cf4f822d7..e1bec27a93 100644 --- a/asmrun/amd64.S +++ b/asmrun/amd64.S @@ -16,28 +16,46 @@ /* Asm part of the runtime system, AMD64 processor */ /* Must be preprocessed by cpp */ -#define FUNCTION_ALIGN 4 +#ifdef SYS_macosx + +#define G(r) _##r +#define FUNCTION_ALIGN 2 +#define EIGHT_ALIGN 3 +#define SIXTEEN_ALIGN 4 +#define FUNCTION(name) \ + .globl name; \ + .align FUNCTION_ALIGN; \ + name: +#else + +#define G(r) r +#define FUNCTION_ALIGN 4 +#define EIGHT_ALIGN 8 +#define SIXTEEN_ALIGN 16 #define FUNCTION(name) \ .globl name; \ - .type name,@function; \ + .type name,@function; \ .align FUNCTION_ALIGN; \ name: +#endif + + .text /* Allocation */ -FUNCTION(caml_call_gc) +FUNCTION(G(caml_call_gc)) /* Record lowest stack address and return address */ movq 0(%rsp), %rax - movq %rax, caml_last_return_address(%rip) + movq %rax, G(caml_last_return_address)(%rip) leaq 8(%rsp), %rax - movq %rax, caml_bottom_of_stack(%rip) + movq %rax, G(caml_bottom_of_stack)(%rip) .L105: /* Save caml_young_ptr, caml_exception_pointer */ - movq %r15, caml_young_ptr(%rip) - movq %r14, caml_exception_pointer(%rip) + movq %r15, G(caml_young_ptr)(%rip) + movq %r14, G(caml_exception_pointer)(%rip) /* Build array of registers, save it into caml_gc_regs */ pushq %r13 pushq %r12 @@ -52,7 +70,7 @@ FUNCTION(caml_call_gc) pushq %rdi pushq %rbx pushq %rax - movq %rsp, caml_gc_regs(%rip) + movq %rsp, G(caml_gc_regs)(%rip) /* Save floating-point registers */ subq $(16*8), %rsp movlpd %xmm0, 0*8(%rsp) @@ -72,7 +90,7 @@ FUNCTION(caml_call_gc) movlpd %xmm14, 14*8(%rsp) movlpd %xmm15, 15*8(%rsp) /* Call the garbage collector */ - call caml_garbage_collection + call G(caml_garbage_collection) /* Restore all regs used by the code generator */ movlpd 0*8(%rsp), %xmm0 movlpd 1*8(%rsp), %xmm1 @@ -105,92 +123,92 @@ FUNCTION(caml_call_gc) popq %r12 popq %r13 /* Restore caml_young_ptr, caml_exception_pointer */ - movq caml_young_ptr(%rip), %r15 - movq caml_exception_pointer(%rip), %r14 + movq G(caml_young_ptr)(%rip), %r15 + movq G(caml_exception_pointer)(%rip), %r14 /* Return to caller */ ret -FUNCTION(caml_alloc1) +FUNCTION(G(caml_alloc1)) subq $16, %r15 - cmpq caml_young_limit(%rip), %r15 + cmpq G(caml_young_limit)(%rip), %r15 jb .L100 ret .L100: movq 0(%rsp), %rax - movq %rax, caml_last_return_address(%rip) + movq %rax, G(caml_last_return_address)(%rip) leaq 8(%rsp), %rax - movq %rax, caml_bottom_of_stack(%rip) + movq %rax, G(caml_bottom_of_stack)(%rip) subq $8, %rsp call .L105 addq $8, %rsp - jmp caml_alloc1 + jmp G(caml_alloc1) -FUNCTION(caml_alloc2) +FUNCTION(G(caml_alloc2)) subq $24, %r15 - cmpq caml_young_limit(%rip), %r15 + cmpq G(caml_young_limit)(%rip), %r15 jb .L101 ret .L101: movq 0(%rsp), %rax - movq %rax, caml_last_return_address(%rip) + movq %rax, G(caml_last_return_address)(%rip) leaq 8(%rsp), %rax - movq %rax, caml_bottom_of_stack(%rip) + movq %rax, G(caml_bottom_of_stack)(%rip) subq $8, %rsp call .L105 addq $8, %rsp - jmp caml_alloc2 + jmp G(caml_alloc2) -FUNCTION(caml_alloc3) +FUNCTION(G(caml_alloc3)) subq $32, %r15 - cmpq caml_young_limit(%rip), %r15 + cmpq G(caml_young_limit)(%rip), %r15 jb .L102 ret .L102: movq 0(%rsp), %rax - movq %rax, caml_last_return_address(%rip) + movq %rax, G(caml_last_return_address)(%rip) leaq 8(%rsp), %rax - movq %rax, caml_bottom_of_stack(%rip) + movq %rax, G(caml_bottom_of_stack)(%rip) subq $8, %rsp call .L105 addq $8, %rsp - jmp caml_alloc3 + jmp G(caml_alloc3) -FUNCTION(caml_allocN) +FUNCTION(G(caml_allocN)) subq %rax, %r15 - cmpq caml_young_limit(%rip), %r15 + cmpq G(caml_young_limit)(%rip), %r15 jb .L103 ret .L103: pushq %rax /* save desired size */ movq 8(%rsp), %rax - movq %rax, caml_last_return_address(%rip) + movq %rax, G(caml_last_return_address)(%rip) leaq 16(%rsp), %rax - movq %rax, caml_bottom_of_stack(%rip) + movq %rax, G(caml_bottom_of_stack)(%rip) call .L105 popq %rax /* recover desired size */ - jmp caml_allocN + jmp G(caml_allocN) /* Call a C function from Caml */ -FUNCTION(caml_c_call) +FUNCTION(G(caml_c_call)) /* Record lowest stack address and return address */ popq %r12 - movq %r12, caml_last_return_address(%rip) - movq %rsp, caml_bottom_of_stack(%rip) + movq %r12, G(caml_last_return_address)(%rip) + movq %rsp, G(caml_bottom_of_stack)(%rip) /* Make the exception handler and alloc ptr available to the C code */ - movq %r15, caml_young_ptr(%rip) - movq %r14, caml_exception_pointer(%rip) + movq %r15, G(caml_young_ptr)(%rip) + movq %r14, G(caml_exception_pointer)(%rip) /* Call the function (address in %rax) */ call *%rax /* Reload alloc ptr */ - movq caml_young_ptr(%rip), %r15 + movq G(caml_young_ptr)(%rip), %r15 /* Return to caller */ pushq %r12 ret /* Start the Caml program */ -FUNCTION(caml_start_program) +FUNCTION(G(caml_start_program)) /* Save callee-save registers */ pushq %rbx pushq %rbp @@ -199,18 +217,18 @@ FUNCTION(caml_start_program) pushq %r14 pushq %r15 subq $8, %rsp /* stack 16-aligned */ - /* Initial entry point is caml_program */ - leaq caml_program(%rip), %r12 + /* Initial entry point is G(caml_program) */ + leaq G(caml_program)(%rip), %r12 /* Common code for caml_start_program and caml_callback* */ .L106: /* Build a callback link */ subq $8, %rsp /* stack 16-aligned */ - pushq caml_gc_regs(%rip) - pushq caml_last_return_address(%rip) - pushq caml_bottom_of_stack(%rip) + pushq G(caml_gc_regs)(%rip) + pushq G(caml_last_return_address)(%rip) + pushq G(caml_bottom_of_stack)(%rip) /* Setup alloc ptr and exception ptr */ - movq caml_young_ptr(%rip), %r15 - movq caml_exception_pointer(%rip), %r14 + movq G(caml_young_ptr)(%rip), %r15 + movq G(caml_exception_pointer)(%rip), %r14 /* Build an exception handler */ lea .L108(%rip), %r13 pushq %r13 @@ -224,12 +242,12 @@ FUNCTION(caml_start_program) popq %r12 /* dummy register */ .L109: /* Update alloc ptr and exception ptr */ - movq %r15, caml_young_ptr(%rip) - movq %r14, caml_exception_pointer(%rip) + movq %r15, G(caml_young_ptr)(%rip) + movq %r14, G(caml_exception_pointer)(%rip) /* Pop the callback link, restoring the global variables */ - popq caml_bottom_of_stack(%rip) - popq caml_last_return_address(%rip) - popq caml_gc_regs(%rip) + popq G(caml_bottom_of_stack)(%rip) + popq G(caml_last_return_address)(%rip) + popq G(caml_gc_regs)(%rip) addq $8, %rsp /* Restore callee-save registers. */ addq $8, %rsp @@ -249,8 +267,8 @@ FUNCTION(caml_start_program) /* Raise an exception from Caml */ -FUNCTION(caml_raise_exn) - testl $1, caml_backtrace_active(%rip) +FUNCTION(G(caml_raise_exn)) + testl $1, G(caml_backtrace_active)(%rip) jne .L110 movq %r14, %rsp popq %r14 @@ -261,7 +279,7 @@ FUNCTION(caml_raise_exn) movq 0(%rsp), %rsi /* arg 2: pc of raise */ leaq 8(%rsp), %rdx /* arg 3: sp of raise */ movq %r14, %rcx /* arg 4: sp of handler */ - call caml_stash_backtrace + call G(caml_stash_backtrace) movq %r12, %rax /* Recover exception bucket */ movq %r14, %rsp popq %r14 @@ -269,30 +287,30 @@ FUNCTION(caml_raise_exn) /* Raise an exception from C */ -FUNCTION(caml_raise_exception) - testl $1, caml_backtrace_active(%rip) +FUNCTION(G(caml_raise_exception)) + testl $1, G(caml_backtrace_active)(%rip) jne .L111 movq %rdi, %rax - movq caml_exception_pointer(%rip), %rsp + movq G(caml_exception_pointer)(%rip), %rsp popq %r14 /* Recover previous exception handler */ - movq caml_young_ptr(%rip), %r15 /* Reload alloc ptr */ + movq G(caml_young_ptr)(%rip), %r15 /* Reload alloc ptr */ ret .L111: movq %rdi, %r12 /* Save exception bucket */ /* arg 1: exception bucket */ - movq caml_last_return_address(%rip), %rsi /* arg 2: pc of raise */ - movq caml_bottom_of_stack(%rip), %rdx /* arg 3: sp of raise */ - movq caml_exception_pointer(%rip), %rcx /* arg 4: sp of handler */ - call caml_stash_backtrace + movq G(caml_last_return_address)(%rip), %rsi /* arg 2: pc of raise */ + movq G(caml_bottom_of_stack)(%rip), %rdx /* arg 3: sp of raise */ + movq G(caml_exception_pointer)(%rip), %rcx /* arg 4: sp of handler */ + call G(caml_stash_backtrace) movq %r12, %rax /* Recover exception bucket */ - movq caml_exception_pointer(%rip), %rsp + movq G(caml_exception_pointer)(%rip), %rsp popq %r14 /* Recover previous exception handler */ - movq caml_young_ptr(%rip), %r15 /* Reload alloc ptr */ + movq G(caml_young_ptr)(%rip), %r15 /* Reload alloc ptr */ ret /* Callback from C to Caml */ -FUNCTION(caml_callback_exn) +FUNCTION(G(caml_callback_exn)) /* Save callee-save registers */ pushq %rbx pushq %rbp @@ -307,7 +325,7 @@ FUNCTION(caml_callback_exn) movq 0(%rbx), %r12 /* code pointer */ jmp .L106 -FUNCTION(caml_callback2_exn) +FUNCTION(G(caml_callback2_exn)) /* Save callee-save registers */ pushq %rbx pushq %rbp @@ -320,10 +338,10 @@ FUNCTION(caml_callback2_exn) /* closure stays in %rdi */ movq %rsi, %rax /* first argument */ movq %rdx, %rbx /* second argument */ - leaq caml_apply2(%rip), %r12 /* code pointer */ + leaq G(caml_apply2)(%rip), %r12 /* code pointer */ jmp .L106 -FUNCTION(caml_callback3_exn) +FUNCTION(G(caml_callback3_exn)) /* Save callee-save registers */ pushq %rbx pushq %rbp @@ -337,34 +355,35 @@ FUNCTION(caml_callback3_exn) movq %rdx, %rbx /* second argument */ movq %rdi, %rsi /* closure */ movq %rcx, %rdi /* third argument */ - leaq caml_apply3(%rip), %r12 /* code pointer */ + leaq G(caml_apply3)(%rip), %r12 /* code pointer */ jmp .L106 -FUNCTION(caml_ml_array_bound_error) - leaq caml_array_bound_error(%rip), %rax - jmp caml_c_call +FUNCTION(G(caml_ml_array_bound_error)) + leaq G(caml_array_bound_error)(%rip), %rax + jmp G(caml_c_call) .data - .globl caml_system__frametable - .type caml_system__frametable,@object - .align 8 -caml_system__frametable: + .globl G(caml_system__frametable) + .align EIGHT_ALIGN +G(caml_system__frametable): .quad 1 /* one descriptor */ .quad .L107 /* return address into callback */ .value -1 /* negative frame size => use callback link */ .value 0 /* no roots here */ - .align 8 + .align EIGHT_ALIGN - .section .rodata.cst8,"a",@progbits - .globl caml_negf_mask - .type caml_negf_mask,@object - .align 16 -caml_negf_mask: +#ifdef SYS_macosx + .literal16 +#else + .section .rodata.cst8,"a",@progbits +#endif + .globl G(caml_negf_mask) + .align SIXTEEN_ALIGN +G(caml_negf_mask): .quad 0x8000000000000000, 0 - .globl caml_absf_mask - .type caml_absf_mask,@object - .align 16 -caml_absf_mask: + .globl G(caml_absf_mask) + .align SIXTEEN_ALIGN +G(caml_absf_mask): .quad 0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF #if defined(SYS_linux) diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h index 0ae285f327..40978231fe 100644 --- a/asmrun/signals_osdep.h +++ b/asmrun/signals_osdep.h @@ -49,6 +49,52 @@ #define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15]) #define CONTEXT_FAULTING_ADDRESS ((char *) context->uc_mcontext.gregs[REG_CR2]) +/****************** AMD64, MacOSX */ + +#elif defined(TARGET_amd64) && defined (SYS_macosx) + + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, void * context) + + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (name); \ + sigact.sa_flags = SA_SIGINFO | SA_64REGSET + + #include <sys/ucontext.h> + #include <AvailabilityMacros.h> + +#if !defined(MAC_OS_X_VERSION_10_5) || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5 + #define CONTEXT_REG(r) r + #else + #define CONTEXT_REG(r) __##r + #endif + + #define CONTEXT_STATE (((ucontext_t *)context)->uc_mcontext->CONTEXT_REG(ss)) + #define CONTEXT_PC (CONTEXT_STATE.CONTEXT_REG(rip)) + #define CONTEXT_EXCEPTION_POINTER (CONTEXT_STATE.CONTEXT_REG(r14)) + #define CONTEXT_YOUNG_PTR (CONTEXT_STATE.CONTEXT_REG(r15)) + #define CONTEXT_SP (CONTEXT_STATE.CONTEXT_REG(rsp)) + #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) + +/****************** AMD64, Solaris x86 */ + +#elif defined(TARGET_amd64) && defined (SYS_solaris) + + #include <ucontext.h> + + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, ucontext_t * context) + + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (void (*)(int,siginfo_t *,void *)) (name); \ + sigact.sa_flags = SA_SIGINFO + + typedef greg_t context_reg; + #define CONTEXT_PC (context->uc_mcontext.gregs[REG_RIP]) + #define CONTEXT_EXCEPTION_POINTER (context->uc_mcontext.gregs[REG_R14]) + #define CONTEXT_YOUNG_PTR (context->uc_mcontext.gregs[REG_R15]) + #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) + /****************** I386, Linux */ #elif defined(TARGET_i386) && defined(SYS_linux_elf) @@ -99,6 +145,19 @@ #define CONTEXT_PC (CONTEXT_STATE.CONTEXT_REG(eip)) #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) +/****************** I386, Solaris x86 */ + +#elif defined(TARGET_i386) && defined(SYS_solaris) + + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, void * context) + + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (name); \ + sigact.sa_flags = SA_SIGINFO + + #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) + /****************** MIPS, all OS */ #elif defined(TARGET_mips) diff --git a/asmrun/startup.c b/asmrun/startup.c index 9f76992b3a..d22e58fe41 100644 --- a/asmrun/startup.c +++ b/asmrun/startup.c @@ -21,6 +21,7 @@ #include "backtrace.h" #include "custom.h" #include "fail.h" +#include "freelist.h" #include "gc.h" #include "gc_ctrl.h" #include "memory.h" @@ -55,7 +56,7 @@ static void init_atoms(void) caml_fatal_error("Fatal error: not enough memory for the initial page table"); for (i = 0; caml_data_segments[i].begin != 0; i++) { - if (caml_page_table_add(In_static_data, + if (caml_page_table_add(In_static_data, caml_data_segments[i].begin, caml_data_segments[i].end) != 0) caml_fatal_error("Fatal error: not enough memory for the initial page table"); @@ -106,6 +107,7 @@ static void scanmult (char *opt, uintnat *var) static void parse_camlrunparam(void) { char *opt = getenv ("OCAMLRUNPARAM"); + uintnat p; if (opt == NULL) opt = getenv ("CAMLRUNPARAM"); @@ -121,6 +123,7 @@ static void parse_camlrunparam(void) case 'v': scanmult (opt, &caml_verb_gc); break; case 'b': caml_record_backtrace(Val_true); break; case 'p': caml_parser_trace = 1; break; + case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break; } } } diff --git a/boot/.cvsignore b/boot/.cvsignore index b9c6f85847..a0a2356c9a 100644 --- a/boot/.cvsignore +++ b/boot/.cvsignore @@ -3,3 +3,4 @@ ocamlrun ocamlyacc camlheader myocamlbuild +myocamlbuild.native diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex e3a281280a..af762efa3b 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex d10e1c2077..4d1adaa9f5 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 0db630253a..8eb679b5df 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/build/buildbot b/build/buildbot index e9b2579eb0..f337e3f6d7 100755 --- a/build/buildbot +++ b/build/buildbot @@ -72,7 +72,7 @@ esac ( ./build/distclean.sh || : ) 2>&1 | log distclean -(cvs -q up -dP -r release310 || bad) 2>&1 | log cvs up +(cvs -q up -dP -r release311 || bad) 2>&1 | log cvs up finish_if_bad case "$opt_win" in diff --git a/build/camlp4-byte-only.sh b/build/camlp4-byte-only.sh index 1b2e359966..ab21fd3495 100755 --- a/build/camlp4-byte-only.sh +++ b/build/camlp4-byte-only.sh @@ -1,9 +1,7 @@ #!/bin/sh # $Id$ set -e -OCAMLBUILD_PARTIAL="true" -export OCAMLBUILD_PARTIAL cd `dirname $0`/.. . build/targets.sh set -x -$OCAMLBUILD $@ byte_stdlib_partial_mode $OCAMLC_BYTE $OCAMLLEX_BYTE $CAMLP4_BYTE +$OCAMLBUILD $@ byte_stdlib_mixed_mode $OCAMLC_BYTE $OCAMLLEX_BYTE $CAMLP4_BYTE diff --git a/build/camlp4-native-only.sh b/build/camlp4-native-only.sh index 638aba9818..42d615880e 100755 --- a/build/camlp4-native-only.sh +++ b/build/camlp4-native-only.sh @@ -1,9 +1,7 @@ #!/bin/sh # $Id$ set -e -OCAMLBUILD_PARTIAL="true" -export OCAMLBUILD_PARTIAL cd `dirname $0`/.. . build/targets.sh set -x -$OCAMLBUILD $@ native_stdlib_partial_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $CAMLP4_NATIVE +$OCAMLBUILD $@ native_stdlib_mixed_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $CAMLP4_NATIVE diff --git a/build/distclean.sh b/build/distclean.sh index 1a88138d85..b3efb3ab93 100755 --- a/build/distclean.sh +++ b/build/distclean.sh @@ -19,6 +19,7 @@ set -ex (cd byterun && make clean) || : (cd asmrun && make clean) || : (cd yacc && make clean) || : +rm -f build/ocamlbuild_mixed_mode rm -rf _build rm -f boot/ocamlrun boot/ocamlrun.exe boot/camlheader \ boot/myocamlbuild boot/myocamlbuild.native boot/myocamlbuild.native.exe \ diff --git a/build/fastworld.sh b/build/fastworld.sh index 59e093a197..ec14da5a7e 100755 --- a/build/fastworld.sh +++ b/build/fastworld.sh @@ -2,10 +2,15 @@ # $Id$ cd `dirname $0` set -e +if [ -e ocamlbuild_mixed_mode ]; then + echo ocamlbuild mixed mode detected + echo 'please cleanup and re-launch (make clean ; ./build/distclean.sh)' + exit 1 +fi ./mkconfig.sh ./mkmyocamlbuild_config.sh . ../config/config.sh -if [ "x$EXE" = "x.exe" ]; then +if [ "x$EXE" = "x.exe" -a "x$SYSTEM" != "xcygwin" ]; then ./boot-c-parts-windows.sh else ./boot-c-parts.sh diff --git a/build/install.sh b/build/install.sh index 06feb41ba0..4c38740c53 100755 --- a/build/install.sh +++ b/build/install.sh @@ -116,6 +116,7 @@ mkdir -p $MANDIR/man$MANEXT echo "Installing core libraries..." installlibdir byterun/libcamlrun.$A asmrun/libasmrun.$A asmrun/libasmrunp.$A \ $LIBDIR +installdir byterun/libcamlrun_shared$EXT_DLL $LIBDIR PUBLIC_INCLUDES="\ alloc.h callback.h config.h custom.h fail.h intext.h \ @@ -161,96 +162,96 @@ installdir \ stdlib/stdlib.cmxa stdlib/stdlib.p.cmxa \ stdlib/camlheader \ stdlib/camlheader_ur \ - stdlib/std_exit.cm[io] \ - stdlib/arg.cmi stdlib/arg.mli \ - stdlib/array.cmi stdlib/array.mli \ - stdlib/arrayLabels.cmi stdlib/arrayLabels.mli \ - stdlib/buffer.cmi stdlib/buffer.mli \ - stdlib/callback.cmi stdlib/callback.mli \ - stdlib/camlinternalLazy.cmi stdlib/camlinternalLazy.mli \ - stdlib/camlinternalMod.cmi stdlib/camlinternalMod.mli \ - stdlib/camlinternalOO.cmi stdlib/camlinternalOO.mli \ - stdlib/char.cmi stdlib/char.mli \ - stdlib/complex.cmi stdlib/complex.mli \ - stdlib/digest.cmi stdlib/digest.mli \ - stdlib/filename.cmi stdlib/filename.mli \ - stdlib/format.cmi stdlib/format.mli \ - stdlib/gc.cmi stdlib/gc.mli \ - stdlib/genlex.cmi stdlib/genlex.mli \ - stdlib/hashtbl.cmi stdlib/hashtbl.mli \ - stdlib/int32.cmi stdlib/int32.mli \ - stdlib/int64.cmi stdlib/int64.mli \ - stdlib/lazy.cmi stdlib/lazy.mli \ - stdlib/lexing.cmi stdlib/lexing.mli \ - stdlib/list.cmi stdlib/list.mli \ - stdlib/listLabels.cmi stdlib/listLabels.mli \ - stdlib/map.cmi stdlib/map.mli \ - stdlib/marshal.cmi stdlib/marshal.mli \ - stdlib/moreLabels.cmi stdlib/moreLabels.mli \ - stdlib/nativeint.cmi stdlib/nativeint.mli \ - stdlib/obj.cmi stdlib/obj.mli \ - stdlib/oo.cmi stdlib/oo.mli \ - stdlib/parsing.cmi stdlib/parsing.mli \ - stdlib/pervasives.cmi stdlib/pervasives.mli \ - stdlib/printexc.cmi stdlib/printexc.mli \ - stdlib/printf.cmi stdlib/printf.mli \ - stdlib/queue.cmi stdlib/queue.mli \ - stdlib/random.cmi stdlib/random.mli \ - stdlib/scanf.cmi stdlib/scanf.mli \ - stdlib/sort.cmi stdlib/sort.mli \ - stdlib/stack.cmi stdlib/stack.mli \ - stdlib/stdLabels.cmi stdlib/stdLabels.mli \ - stdlib/stream.cmi stdlib/stream.mli \ - stdlib/string.cmi stdlib/string.mli \ - stdlib/stringLabels.cmi stdlib/stringLabels.mli \ - stdlib/sys.cmi stdlib/sys.mli \ - stdlib/weak.cmi stdlib/weak.mli \ - stdlib/$set.cmi stdlib/$set.mli \ - stdlib/arg.cmx stdlib/arg.p.cmx stdlib/arg.$O stdlib/arg.p.$O \ - stdlib/array.cmx stdlib/array.p.cmx stdlib/array.$O stdlib/array.p.$O \ - stdlib/arrayLabels.cmx stdlib/arrayLabels.p.cmx stdlib/arrayLabels.$O stdlib/arrayLabels.p.$O \ - stdlib/buffer.cmx stdlib/buffer.p.cmx stdlib/buffer.$O stdlib/buffer.p.$O \ - stdlib/callback.cmx stdlib/callback.p.cmx stdlib/callback.$O stdlib/callback.p.$O \ - stdlib/camlinternalLazy.cmx stdlib/camlinternalLazy.p.cmx stdlib/camlinternalLazy.$O stdlib/camlinternalLazy.p.$O \ - stdlib/camlinternalMod.cmx stdlib/camlinternalMod.p.cmx stdlib/camlinternalMod.$O stdlib/camlinternalMod.p.$O \ - stdlib/camlinternalOO.cmx stdlib/camlinternalOO.p.cmx stdlib/camlinternalOO.$O stdlib/camlinternalOO.p.$O \ - stdlib/char.cmx stdlib/char.p.cmx stdlib/char.$O stdlib/char.p.$O \ - stdlib/complex.cmx stdlib/complex.p.cmx stdlib/complex.$O stdlib/complex.p.$O \ - stdlib/digest.cmx stdlib/digest.p.cmx stdlib/digest.$O stdlib/digest.p.$O \ - stdlib/filename.cmx stdlib/filename.p.cmx stdlib/filename.$O stdlib/filename.p.$O \ - stdlib/format.cmx stdlib/format.p.cmx stdlib/format.$O stdlib/format.p.$O \ - stdlib/gc.cmx stdlib/gc.p.cmx stdlib/gc.$O stdlib/gc.p.$O \ - stdlib/genlex.cmx stdlib/genlex.p.cmx stdlib/genlex.$O stdlib/genlex.p.$O \ - stdlib/hashtbl.cmx stdlib/hashtbl.p.cmx stdlib/hashtbl.$O stdlib/hashtbl.p.$O \ - stdlib/int32.cmx stdlib/int32.p.cmx stdlib/int32.$O stdlib/int32.p.$O \ - stdlib/int64.cmx stdlib/int64.p.cmx stdlib/int64.$O stdlib/int64.p.$O \ - stdlib/lazy.cmx stdlib/lazy.p.cmx stdlib/lazy.$O stdlib/lazy.p.$O \ - stdlib/lexing.cmx stdlib/lexing.p.cmx stdlib/lexing.$O stdlib/lexing.p.$O \ - stdlib/list.cmx stdlib/list.p.cmx stdlib/list.$O stdlib/list.p.$O \ - stdlib/listLabels.cmx stdlib/listLabels.p.cmx stdlib/listLabels.$O stdlib/listLabels.p.$O \ - stdlib/map.cmx stdlib/map.p.cmx stdlib/map.$O stdlib/map.p.$O \ - stdlib/marshal.cmx stdlib/marshal.p.cmx stdlib/marshal.$O stdlib/marshal.p.$O \ - stdlib/moreLabels.cmx stdlib/moreLabels.p.cmx stdlib/moreLabels.$O stdlib/moreLabels.p.$O \ - stdlib/nativeint.cmx stdlib/nativeint.p.cmx stdlib/nativeint.$O stdlib/nativeint.p.$O \ - stdlib/obj.cmx stdlib/obj.p.cmx stdlib/obj.$O stdlib/obj.p.$O \ - stdlib/oo.cmx stdlib/oo.p.cmx stdlib/oo.$O stdlib/oo.p.$O \ - stdlib/parsing.cmx stdlib/parsing.p.cmx stdlib/parsing.$O stdlib/parsing.p.$O \ - stdlib/pervasives.cmx stdlib/pervasives.p.cmx stdlib/pervasives.$O stdlib/pervasives.p.$O \ - stdlib/printexc.cmx stdlib/printexc.p.cmx stdlib/printexc.$O stdlib/printexc.p.$O \ - stdlib/printf.cmx stdlib/printf.p.cmx stdlib/printf.$O stdlib/printf.p.$O \ - stdlib/queue.cmx stdlib/queue.p.cmx stdlib/queue.$O stdlib/queue.p.$O \ - stdlib/random.cmx stdlib/random.p.cmx stdlib/random.$O stdlib/random.p.$O \ - stdlib/scanf.cmx stdlib/scanf.p.cmx stdlib/scanf.$O stdlib/scanf.p.$O \ - stdlib/sort.cmx stdlib/sort.p.cmx stdlib/sort.$O stdlib/sort.p.$O \ - stdlib/stack.cmx stdlib/stack.p.cmx stdlib/stack.$O stdlib/stack.p.$O \ - stdlib/stdLabels.cmx stdlib/stdLabels.p.cmx stdlib/stdLabels.$O stdlib/stdLabels.p.$O \ + stdlib/std_exit.cm[io] stdlib/std_exit.ml \ + stdlib/arg.cmi stdlib/arg.ml stdlib/arg.mli \ + stdlib/array.cmi stdlib/array.ml stdlib/array.mli \ + stdlib/arrayLabels.cmi stdlib/arrayLabels.ml stdlib/arrayLabels.mli \ + stdlib/buffer.cmi stdlib/buffer.ml stdlib/buffer.mli \ + stdlib/callback.cmi stdlib/callback.ml stdlib/callback.mli \ + stdlib/camlinternalLazy.cmi stdlib/camlinternalLazy.ml stdlib/camlinternalLazy.mli \ + stdlib/camlinternalMod.cmi stdlib/camlinternalMod.ml stdlib/camlinternalMod.mli \ + stdlib/camlinternalOO.cmi stdlib/camlinternalOO.ml stdlib/camlinternalOO.mli \ + stdlib/char.cmi stdlib/char.ml stdlib/char.mli \ + stdlib/complex.cmi stdlib/complex.ml stdlib/complex.mli \ + stdlib/digest.cmi stdlib/digest.ml stdlib/digest.mli \ + stdlib/filename.cmi stdlib/filename.ml stdlib/filename.mli \ + stdlib/format.cmi stdlib/format.ml stdlib/format.mli \ + stdlib/gc.cmi stdlib/gc.ml stdlib/gc.mli \ + stdlib/genlex.cmi stdlib/genlex.ml stdlib/genlex.mli \ + stdlib/hashtbl.cmi stdlib/hashtbl.ml stdlib/hashtbl.mli \ + stdlib/int32.cmi stdlib/int32.ml stdlib/int32.mli \ + stdlib/int64.cmi stdlib/int64.ml stdlib/int64.mli \ + stdlib/lazy.cmi stdlib/lazy.ml stdlib/lazy.mli \ + stdlib/lexing.cmi stdlib/lexing.ml stdlib/lexing.mli \ + stdlib/list.cmi stdlib/list.ml stdlib/list.mli \ + stdlib/listLabels.cmi stdlib/listLabels.ml stdlib/listLabels.mli \ + stdlib/map.cmi stdlib/map.ml stdlib/map.mli \ + stdlib/marshal.cmi stdlib/marshal.ml stdlib/marshal.mli \ + stdlib/moreLabels.cmi stdlib/moreLabels.ml stdlib/moreLabels.mli \ + stdlib/nativeint.cmi stdlib/nativeint.ml stdlib/nativeint.mli \ + stdlib/obj.cmi stdlib/obj.ml stdlib/obj.mli \ + stdlib/oo.cmi stdlib/oo.ml stdlib/oo.mli \ + stdlib/parsing.cmi stdlib/parsing.ml stdlib/parsing.mli \ + stdlib/pervasives.cmi stdlib/pervasives.ml stdlib/pervasives.mli \ + stdlib/printexc.cmi stdlib/printexc.ml stdlib/printexc.mli \ + stdlib/printf.cmi stdlib/printf.ml stdlib/printf.mli \ + stdlib/queue.cmi stdlib/queue.ml stdlib/queue.mli \ + stdlib/random.cmi stdlib/random.ml stdlib/random.mli \ + stdlib/scanf.cmi stdlib/scanf.ml stdlib/scanf.mli \ + stdlib/sort.cmi stdlib/sort.ml stdlib/sort.mli \ + stdlib/stack.cmi stdlib/stack.ml stdlib/stack.mli \ + stdlib/stdLabels.cmi stdlib/stdLabels.ml stdlib/stdLabels.mli \ + stdlib/stream.cmi stdlib/stream.ml stdlib/stream.mli \ + stdlib/string.cmi stdlib/string.ml stdlib/string.mli \ + stdlib/stringLabels.cmi stdlib/stringLabels.ml stdlib/stringLabels.mli \ + stdlib/sys.cmi stdlib/sys.ml stdlib/sys.mli \ + stdlib/weak.cmi stdlib/weak.ml stdlib/weak.mli \ + stdlib/$set.cmi stdlib/$set.ml stdlib/$set.mli \ + stdlib/arg.cmx stdlib/arg.p.cmx \ + stdlib/array.cmx stdlib/array.p.cmx \ + stdlib/arrayLabels.cmx stdlib/arrayLabels.p.cmx \ + stdlib/buffer.cmx stdlib/buffer.p.cmx \ + stdlib/callback.cmx stdlib/callback.p.cmx \ + stdlib/camlinternalLazy.cmx stdlib/camlinternalLazy.p.cmx \ + stdlib/camlinternalMod.cmx stdlib/camlinternalMod.p.cmx \ + stdlib/camlinternalOO.cmx stdlib/camlinternalOO.p.cmx \ + stdlib/char.cmx stdlib/char.p.cmx \ + stdlib/complex.cmx stdlib/complex.p.cmx \ + stdlib/digest.cmx stdlib/digest.p.cmx \ + stdlib/filename.cmx stdlib/filename.p.cmx \ + stdlib/format.cmx stdlib/format.p.cmx \ + stdlib/gc.cmx stdlib/gc.p.cmx \ + stdlib/genlex.cmx stdlib/genlex.p.cmx \ + stdlib/hashtbl.cmx stdlib/hashtbl.p.cmx \ + stdlib/int32.cmx stdlib/int32.p.cmx \ + stdlib/int64.cmx stdlib/int64.p.cmx \ + stdlib/lazy.cmx stdlib/lazy.p.cmx \ + stdlib/lexing.cmx stdlib/lexing.p.cmx \ + stdlib/list.cmx stdlib/list.p.cmx \ + stdlib/listLabels.cmx stdlib/listLabels.p.cmx \ + stdlib/map.cmx stdlib/map.p.cmx \ + stdlib/marshal.cmx stdlib/marshal.p.cmx \ + stdlib/moreLabels.cmx stdlib/moreLabels.p.cmx \ + stdlib/nativeint.cmx stdlib/nativeint.p.cmx \ + stdlib/obj.cmx stdlib/obj.p.cmx \ + stdlib/oo.cmx stdlib/oo.p.cmx \ + stdlib/parsing.cmx stdlib/parsing.p.cmx \ + stdlib/pervasives.cmx stdlib/pervasives.p.cmx \ + stdlib/printexc.cmx stdlib/printexc.p.cmx \ + stdlib/printf.cmx stdlib/printf.p.cmx \ + stdlib/queue.cmx stdlib/queue.p.cmx \ + stdlib/random.cmx stdlib/random.p.cmx \ + stdlib/scanf.cmx stdlib/scanf.p.cmx \ + stdlib/sort.cmx stdlib/sort.p.cmx \ + stdlib/stack.cmx stdlib/stack.p.cmx \ + stdlib/stdLabels.cmx stdlib/stdLabels.p.cmx \ stdlib/std_exit.cmx stdlib/std_exit.p.cmx stdlib/std_exit.$O stdlib/std_exit.p.$O \ - stdlib/stream.cmx stdlib/stream.p.cmx stdlib/stream.$O stdlib/stream.p.$O \ - stdlib/string.cmx stdlib/string.p.cmx stdlib/string.$O stdlib/string.p.$O \ - stdlib/stringLabels.cmx stdlib/stringLabels.p.cmx stdlib/stringLabels.$O stdlib/stringLabels.p.$O \ - stdlib/sys.cmx stdlib/sys.p.cmx stdlib/sys.$O stdlib/sys.p.$O \ - stdlib/weak.cmx stdlib/weak.p.cmx stdlib/weak.$O stdlib/weak.p.$O \ - stdlib/$set.cmx stdlib/$set.p.cmx stdlib/$set.$O stdlib/$set.p.$O \ + stdlib/stream.cmx stdlib/stream.p.cmx \ + stdlib/string.cmx stdlib/string.p.cmx \ + stdlib/stringLabels.cmx stdlib/stringLabels.p.cmx \ + stdlib/sys.cmx stdlib/sys.p.cmx \ + stdlib/weak.cmx stdlib/weak.p.cmx \ + stdlib/$set.cmx stdlib/$set.p.cmx \ $LIBDIR installlibdir \ @@ -274,7 +275,6 @@ installbin tools/addlabels.byte $LIBDIR/addlabels installbin tools/scrapelabels.byte $LIBDIR/scrapelabels installbin otherlibs/dynlink/extract_crc.byte $LIBDIR/extract_crc installbin otherlibs/labltk/lib/labltk$EXE $BINDIR/labltk$EXE -installbin otherlibs/labltk/compiler/tkcompiler$EXE $BINDIR/tkcompiler$EXE installbin otherlibs/labltk/browser/ocamlbrowser$EXE $BINDIR/ocamlbrowser$EXE installbin otherlibs/labltk/compiler/pp$EXE $LIBDIR/labltk/pp$EXE installbin otherlibs/labltk/lib/labltktop$EXE $LIBDIR/labltk/labltktop$EXE @@ -290,6 +290,7 @@ installdir \ otherlibs/"$WIN32"unix/unix.cma \ otherlibs/bigarray/bigarray.cmxa \ otherlibs/dbm/dbm.cmxa \ + otherlibs/dynlink/dynlink.cmxa \ otherlibs/"$WIN32"graph/graphics.cmxa \ otherlibs/num/nums.cmxa \ otherlibs/str/str.cmxa \ @@ -325,17 +326,17 @@ installdir \ otherlibs/labltk/support/tkthread.cmi \ otherlibs/labltk/support/tkthread.cmo \ otherlibs/labltk/support/tkthread.$O \ - otherlibs/labltk/labltk/*.mli \ + otherlibs/labltk/support/tkthread.cmx \ + otherlibs/labltk/labltk/[^_]*.mli \ otherlibs/labltk/labltk/*.cmi \ otherlibs/labltk/labltk/*.cmx \ - otherlibs/labltk/camltk/*.mli \ + otherlibs/labltk/camltk/[^_]*.mli \ otherlibs/labltk/camltk/*.cmi \ otherlibs/labltk/camltk/*.cmx \ otherlibs/labltk/frx/frxlib.cma \ otherlibs/labltk/frx/frxlib.cmxa \ - otherlibs/labltk/frx/*.mli \ + ../otherlibs/labltk/frx/*.mli \ otherlibs/labltk/frx/*.cmi \ - otherlibs/labltk/frx/*.cmx \ otherlibs/labltk/jpf/jpflib.cma \ otherlibs/labltk/jpf/jpflib.cmxa \ otherlibs/labltk/jpf/*.mli \ @@ -343,20 +344,27 @@ installdir \ otherlibs/labltk/jpf/*.cmx \ otherlibs/labltk/lib/labltk.cma \ otherlibs/labltk/lib/labltk.cmxa \ + otherlibs/labltk/lib/labltk.cmx \ otherlibs/labltk/tkanim/*.mli \ otherlibs/labltk/tkanim/*.cmi \ otherlibs/labltk/tkanim/tkanim.cma \ otherlibs/labltk/tkanim/tkanim.cmxa \ + otherlibs/labltk/compiler/tkcompiler \ $LIBDIR/labltk installdir \ otherlibs/systhreads/threads.cma \ otherlibs/systhreads/threads.cmxa \ otherlibs/systhreads/thread.cmi \ + otherlibs/systhreads/thread.cmx \ otherlibs/systhreads/mutex.cmi \ + otherlibs/systhreads/mutex.cmx \ otherlibs/systhreads/condition.cmi \ + otherlibs/systhreads/condition.cmx \ otherlibs/systhreads/event.cmi \ + otherlibs/systhreads/event.cmx \ otherlibs/systhreads/threadUnix.cmi \ + otherlibs/systhreads/threadUnix.cmx \ $LIBDIR/threads installdir \ @@ -420,50 +428,54 @@ installdir \ toplevel/topdirs.cmi \ toplevel/topmain.cmi \ typing/outcometree.cmi \ + typing/outcometree.mli \ otherlibs/graph/graphicsX11.cmi \ + otherlibs/graph/graphicsX11.mli \ otherlibs/dynlink/dynlink.cmi \ + otherlibs/dynlink/dynlink.mli \ otherlibs/num/arith_status.cmi \ + otherlibs/num/arith_status.mli \ otherlibs/num/big_int.cmi \ + otherlibs/num/big_int.mli \ otherlibs/num/nat.cmi \ + otherlibs/num/nat.mli \ otherlibs/num/num.cmi \ + otherlibs/num/num.mli \ otherlibs/num/ratio.cmi \ + otherlibs/num/ratio.mli \ otherlibs/bigarray/bigarray.cmi \ + otherlibs/bigarray/bigarray.mli \ otherlibs/dbm/dbm.cmi \ + otherlibs/dbm/dbm.mli \ + otherlibs/dynlink/dynlink.cmx \ otherlibs/"$WIN32"graph/graphics.cmi \ + otherlibs/"$WIN32"graph/graphics.mli \ otherlibs/str/str.cmi \ + otherlibs/str/str.mli \ otherlibs/"$WIN32"unix/unix.cmi \ + otherlibs/"$WIN32"unix/unix.mli \ otherlibs/"$WIN32"unix/unixLabels.cmi \ + otherlibs/"$WIN32"unix/unixLabels.mli \ otherlibs/num/arith_flags.cmx \ - otherlibs/num/arith_flags.$O \ otherlibs/num/int_misc.cmx \ - otherlibs/num/int_misc.$O \ otherlibs/num/arith_status.cmx \ - otherlibs/num/arith_status.$O \ otherlibs/num/big_int.cmx \ - otherlibs/num/big_int.$O \ otherlibs/num/nat.cmx \ - otherlibs/num/nat.$O \ otherlibs/num/num.cmx \ - otherlibs/num/num.$O \ otherlibs/num/ratio.cmx \ - otherlibs/num/ratio.$O \ otherlibs/bigarray/bigarray.cmx \ - otherlibs/bigarray/bigarray.$O \ otherlibs/dbm/dbm.cmx \ - otherlibs/dbm/dbm.$O \ otherlibs/"$WIN32"graph/graphics.cmx \ - otherlibs/"$WIN32"graph/graphics.$O \ + otherlibs/graph/graphicsX11.cmx \ otherlibs/str/str.cmx \ - otherlibs/str/str.$O \ otherlibs/"$WIN32"unix/unix.cmx \ - otherlibs/"$WIN32"unix/unix.$O \ otherlibs/"$WIN32"unix/unixLabels.cmx \ - otherlibs/"$WIN32"unix/unixLabels.$O \ $LIBDIR installlibdir \ otherlibs/bigarray/bigarray.$A \ otherlibs/dbm/dbm.$A \ + otherlibs/dynlink/dynlink.$A \ otherlibs/"$WIN32"graph/graphics.$A \ otherlibs/num/nums.$A \ otherlibs/str/str.$A \ diff --git a/build/ocamlbuild-byte-only.sh b/build/ocamlbuild-byte-only.sh index 87e7ba3a05..8b010142fc 100755 --- a/build/ocamlbuild-byte-only.sh +++ b/build/ocamlbuild-byte-only.sh @@ -1,9 +1,7 @@ #!/bin/sh # $Id$ set -e -OCAMLBUILD_PARTIAL="true" -export OCAMLBUILD_PARTIAL cd `dirname $0`/.. . build/targets.sh set -x -$OCAMLBUILD $@ byte_stdlib_partial_mode $OCAMLC_BYTE $OCAMLLEX_BYTE $OCAMLBUILD_BYTE +$OCAMLBUILD $@ byte_stdlib_mixed_mode $OCAMLC_BYTE $OCAMLLEX_BYTE $OCAMLBUILD_BYTE diff --git a/build/ocamlbuild-native-only.sh b/build/ocamlbuild-native-only.sh index 03d93edc1c..823964a7c7 100755 --- a/build/ocamlbuild-native-only.sh +++ b/build/ocamlbuild-native-only.sh @@ -1,9 +1,7 @@ #!/bin/sh # $Id$ set -e -OCAMLBUILD_PARTIAL="true" -export OCAMLBUILD_PARTIAL cd `dirname $0`/.. . build/targets.sh set -x -$OCAMLBUILD $@ native_stdlib_partial_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $OCAMLBUILD_NATIVE +$OCAMLBUILD $@ native_stdlib_mixed_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $OCAMLBUILD_NATIVE diff --git a/build/ocamlbuildlib-native-only.sh b/build/ocamlbuildlib-native-only.sh index b603bc57d2..7afdf72511 100755 --- a/build/ocamlbuildlib-native-only.sh +++ b/build/ocamlbuildlib-native-only.sh @@ -1,9 +1,7 @@ #!/bin/sh # $Id$ set -e -OCAMLBUILD_PARTIAL="true" -export OCAMLBUILD_PARTIAL cd `dirname $0`/.. . build/targets.sh set -x -$OCAMLBUILD $@ native_stdlib_partial_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $OCAMLBUILDLIB_NATIVE +$OCAMLBUILD $@ native_stdlib_mixed_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $OCAMLBUILDLIB_NATIVE diff --git a/build/otherlibs-targets.sh b/build/otherlibs-targets.sh index 24df9a6d91..2167dd3349 100644 --- a/build/otherlibs-targets.sh +++ b/build/otherlibs-targets.sh @@ -39,6 +39,7 @@ add_c_lib() { add_ocaml_lib() { add_native "$1.cmxa" + add_native "$1.$A" add_byte "$1.cma" } @@ -94,7 +95,7 @@ for lib in $OTHERLIBRARIES; do add_c_lib mldbm;; dynlink) add_ocaml_lib dynlink - add_native dynlink.cmx + add_native dynlink.cmx dynlink.$O add_file $lib.cmi extract_crc;; win32unix) UNIXDIR="otherlibs/win32unix" diff --git a/build/partial-boot.sh b/build/partial-boot.sh deleted file mode 100755 index ee6676eadb..0000000000 --- a/build/partial-boot.sh +++ /dev/null @@ -1,25 +0,0 @@ -#!/bin/sh - -######################################################################### -# # -# Objective Caml # -# # -# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 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. # -# # -######################################################################### - -# $Id$ - -set -ex -cd `dirname $0`/.. -OCAMLBUILD_PARTIAL="true" -export OCAMLBUILD_PARTIAL -mkdir -p _build -cp -rf boot _build/ -./build/mkconfig.sh -./build/mkmyocamlbuild_config.sh -./build/boot.sh diff --git a/build/world.sh b/build/world.sh index 1acf2b5944..94946ebcca 100755 --- a/build/world.sh +++ b/build/world.sh @@ -1,11 +1,16 @@ #!/bin/sh # $Id$ cd `dirname $0` -set -ex +set -e +if [ -e ocamlbuild_mixed_mode ]; then + echo ocamlbuild mixed mode detected + echo 'please cleanup and re-launch (make clean ; ./build/distclean.sh)' + exit 1 +fi ./mkconfig.sh ./mkmyocamlbuild_config.sh . ../config/config.sh -if [ "x$EXE" = "x.exe" ]; then +if [ "x$EXE" = "x.exe" -a "x$SYSTEM" != "xcygwin" ]; then ./boot-c-parts-windows.sh else ./boot-c-parts.sh diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index f7911aa3e5..09c254d4f3 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -171,6 +171,7 @@ let copy_event ev kind info repr = ev_kind = kind; ev_info = info; ev_typenv = ev.ev_typenv; + ev_typsubst = ev.ev_typsubst; ev_compenv = ev.ev_compenv; ev_stacksize = ev.ev_stacksize; ev_repr = repr } @@ -714,6 +715,7 @@ let rec comp_expr env exp sz cont = ev_kind = kind; ev_info = info; ev_typenv = lev.lev_env; + ev_typsubst = Subst.identity; ev_compenv = env; ev_stacksize = sz; ev_repr = diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index bb3a80aa6b..31eff07faa 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -66,9 +66,11 @@ let rename_relocation objfile mapping defined base (rel, ofs) = (* Record and relocate a debugging event *) -let relocate_debug base ev = - ev.ev_pos <- base + ev.ev_pos; - events := ev :: !events +let relocate_debug base prefix subst ev = + let ev' = { ev with ev_pos = base + ev.ev_pos; + ev_module = prefix ^ "." ^ ev.ev_module; + ev_typsubst = Subst.compose ev.ev_typsubst subst } in + events := ev' :: !events (* Read the unit information from a .cmo file. *) @@ -110,7 +112,7 @@ let read_member_info file = Accumulate relocs, debug info, etc. Return size of bytecode. *) -let rename_append_bytecode oc mapping defined ofs objfile compunit = +let rename_append_bytecode oc mapping defined ofs prefix subst objfile compunit = let ic = open_in_bin objfile in try Bytelink.check_consistency objfile compunit; @@ -123,7 +125,7 @@ let rename_append_bytecode oc mapping defined ofs objfile compunit = Misc.copy_file_chunk ic oc compunit.cu_codesize; if !Clflags.debug && compunit.cu_debug > 0 then begin seek_in ic compunit.cu_debug; - List.iter (relocate_debug ofs) (input_value ic); + List.iter (relocate_debug ofs prefix subst) (input_value ic); end; close_in ic; compunit.cu_codesize @@ -134,20 +136,22 @@ let rename_append_bytecode oc mapping defined ofs objfile compunit = (* Same, for a list of .cmo and .cmi files. Return total size of bytecode. *) -let rec rename_append_bytecode_list oc mapping defined ofs = function +let rec rename_append_bytecode_list oc mapping defined ofs prefix subst = function [] -> ofs | m :: rem -> match m.pm_kind with | PM_intf -> - rename_append_bytecode_list oc mapping defined ofs rem + rename_append_bytecode_list oc mapping defined ofs prefix subst rem | PM_impl compunit -> let size = - rename_append_bytecode oc mapping defined ofs + rename_append_bytecode oc mapping defined ofs prefix subst m.pm_file compunit in + let id = Ident.create_persistent m.pm_name in + let root = Path.Pident (Ident.create_persistent prefix) in rename_append_bytecode_list - oc mapping (Ident.create_persistent m.pm_name :: defined) - (ofs + size) rem + oc mapping (id :: defined) + (ofs + size) prefix (Subst.add_module id (Path.Pdot (root, Ident.name id, Path.nopos)) subst) rem (* Generate the code that builds the tuple representing the package module *) @@ -187,7 +191,7 @@ let package_object_files files targetfile targetname coercion = let pos_depl = pos_out oc in output_binary_int oc 0; let pos_code = pos_out oc in - let ofs = rename_append_bytecode_list oc mapping [] 0 members in + let ofs = rename_append_bytecode_list oc mapping [] 0 targetname Subst.identity members in build_global_target oc targetname members mapping ofs coercion; let pos_debug = pos_out oc in if !Clflags.debug && !events <> [] then diff --git a/bytecomp/dll.ml b/bytecomp/dll.ml index 949e63e2a1..76ca78a77f 100644 --- a/bytecomp/dll.ml +++ b/bytecomp/dll.ml @@ -85,13 +85,16 @@ let close_all_dlls () = Raise [Not_found] if not found. *) let find_primitive prim_name = - let rec find = function + let rec find seen = function [] -> raise Not_found | dll :: rem -> let addr = dll_sym dll prim_name in - if addr == Obj.magic () then find rem else addr in - find !opened_dlls + if addr == Obj.magic () then find (dll :: seen) rem else begin + if seen <> [] then opened_dlls := dll :: List.rev_append seen rem; + addr + end in + find [] !opened_dlls (* If linking in core (dynlink or toplevel), synchronize the VM table of primitive with the linker's table of primitive diff --git a/bytecomp/instruct.ml b/bytecomp/instruct.ml index 9fd2cb9409..4f4fa14fa1 100644 --- a/bytecomp/instruct.ml +++ b/bytecomp/instruct.ml @@ -26,6 +26,7 @@ type debug_event = ev_kind: debug_event_kind; (* Before/after event *) ev_info: debug_event_info; (* Extra information *) ev_typenv: Env.summary; (* Typing environment *) + ev_typsubst: Subst.t; (* Substitution over types *) ev_compenv: compilation_env; (* Compilation environment *) ev_stacksize: int; (* Size of stack frame *) ev_repr: debug_event_repr } (* Position of the representative *) diff --git a/bytecomp/instruct.mli b/bytecomp/instruct.mli index b7dbd7e3ba..2dfc417ceb 100644 --- a/bytecomp/instruct.mli +++ b/bytecomp/instruct.mli @@ -43,6 +43,7 @@ type debug_event = ev_kind: debug_event_kind; (* Before/after event *) ev_info: debug_event_info; (* Extra information *) ev_typenv: Env.summary; (* Typing environment *) + ev_typsubst: Subst.t; (* Substitution over types *) ev_compenv: compilation_env; (* Compilation environment *) ev_stacksize: int; (* Size of stack frame *) ev_repr: debug_event_repr } (* Position of the representative *) diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 5187c6d504..98c1e0878f 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -609,12 +609,20 @@ let transl_class ids cl_id arity pub_meths cl vflag = let meth_ids = get_class_meths cl in let subst env lam i0 new_ids' = let fv = free_variables lam in + (* prerr_ids "cl_id =" [cl_id]; prerr_ids "fv =" (IdentSet.elements fv); *) let fv = List.fold_right IdentSet.remove !new_ids' fv in - let fv = IdentSet.filter (fun id -> List.mem id new_ids) fv in - (* need to handle methods specially (PR#3576) *) - let fm = IdentSet.diff (free_methods lam) meth_ids in - let fv = IdentSet.union fv fm in + (* We need to handle method ids specially, as they do not appear + in the typing environment (PR#3576, PR#4560) *) + (* very hacky: we add and remove free method ids on the fly, + depending on the visit order... *) + method_ids := + IdentSet.diff (IdentSet.union (free_methods lam) !method_ids) meth_ids; + (* prerr_ids "meth_ids =" (IdentSet.elements meth_ids); + prerr_ids "method_ids =" (IdentSet.elements !method_ids); *) + let new_ids = List.fold_right IdentSet.add new_ids !method_ids in + let fv = IdentSet.inter fv new_ids in new_ids' := !new_ids' @ IdentSet.elements fv; + (* prerr_ids "new_ids' =" !new_ids'; *) let i = ref (i0-1) in List.fold_left (fun subst id -> diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index 9899e44b3e..e97fbfc13d 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -123,6 +123,7 @@ let transl_store_label_init glob size f arg = let wrapping = ref false let top_env = ref Env.empty let classes = ref [] +let method_ids = ref IdentSet.empty let oo_add_class id = classes := id :: !classes; @@ -138,6 +139,7 @@ let oo_wrap env req f x = cache_required := req; top_env := env; classes := []; + method_ids := IdentSet.empty; let lambda = f x in let lambda = List.fold_left diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli index d6e432da5c..26fa504b45 100644 --- a/bytecomp/translobj.mli +++ b/bytecomp/translobj.mli @@ -24,5 +24,7 @@ val transl_label_init: lambda -> lambda val transl_store_label_init: Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda +val method_ids: IdentSet.t ref (* reset when starting a new wrapper *) + val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda val oo_add_class: Ident.t -> Env.t * bool diff --git a/byterun/.depend b/byterun/.depend index 9e2a3d100a..b92cc6de2a 100644 --- a/byterun/.depend +++ b/byterun/.depend @@ -105,20 +105,20 @@ printexc.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \ roots.o: roots.c finalise.h roots.h misc.h compatibility.h config.h \ ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ freelist.h minor_gc.h globroots.h stacks.h -signals_byt.o: signals_byt.c config.h ../config/m.h ../config/s.h \ - compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ - minor_gc.h osdeps.h signals.h signals_machdep.h signals.o: signals.c alloc.h compatibility.h misc.h config.h \ ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ sys.h +signals_byt.o: signals_byt.c config.h ../config/m.h ../config/s.h \ + compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ + minor_gc.h osdeps.h signals.h signals_machdep.h stacks.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.h \ fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h startup.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ alloc.h misc.h mlvalues.h backtrace.h callback.h custom.h debugger.h \ - dynlink.h exec.h fail.h fix_code.h gc_ctrl.h instrtrace.h interp.h \ - intext.h io.h memory.h gc.h major_gc.h freelist.h minor_gc.h osdeps.h \ + dynlink.h exec.h fail.h fix_code.h freelist.h gc_ctrl.h instrtrace.h \ + interp.h intext.h io.h memory.h gc.h major_gc.h minor_gc.h osdeps.h \ prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ version.h str.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ @@ -243,20 +243,20 @@ printexc.d.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \ roots.d.o: roots.c finalise.h roots.h misc.h compatibility.h config.h \ ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ freelist.h minor_gc.h globroots.h stacks.h -signals_byt.d.o: signals_byt.c config.h ../config/m.h ../config/s.h \ - compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ - minor_gc.h osdeps.h signals.h signals_machdep.h signals.d.o: signals.c alloc.h compatibility.h misc.h config.h \ ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ sys.h +signals_byt.d.o: signals_byt.c config.h ../config/m.h ../config/s.h \ + compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ + minor_gc.h osdeps.h signals.h signals_machdep.h stacks.d.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.h \ fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h startup.d.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ alloc.h misc.h mlvalues.h backtrace.h callback.h custom.h debugger.h \ - dynlink.h exec.h fail.h fix_code.h gc_ctrl.h instrtrace.h interp.h \ - intext.h io.h memory.h gc.h major_gc.h freelist.h minor_gc.h osdeps.h \ + dynlink.h exec.h fail.h fix_code.h freelist.h gc_ctrl.h instrtrace.h \ + interp.h intext.h io.h memory.h gc.h major_gc.h minor_gc.h osdeps.h \ prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ version.h str.d.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ @@ -379,20 +379,20 @@ printexc.pic.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \ roots.pic.o: roots.c finalise.h roots.h misc.h compatibility.h config.h \ ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ freelist.h minor_gc.h globroots.h stacks.h -signals_byt.pic.o: signals_byt.c config.h ../config/m.h ../config/s.h \ - compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ - minor_gc.h osdeps.h signals.h signals_machdep.h signals.pic.o: signals.c alloc.h compatibility.h misc.h config.h \ ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ sys.h +signals_byt.pic.o: signals_byt.c config.h ../config/m.h ../config/s.h \ + compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ + minor_gc.h osdeps.h signals.h signals_machdep.h stacks.pic.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.h \ fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h startup.pic.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ alloc.h misc.h mlvalues.h backtrace.h callback.h custom.h debugger.h \ - dynlink.h exec.h fail.h fix_code.h gc_ctrl.h instrtrace.h interp.h \ - intext.h io.h memory.h gc.h major_gc.h freelist.h minor_gc.h osdeps.h \ + dynlink.h exec.h fail.h fix_code.h freelist.h gc_ctrl.h instrtrace.h \ + interp.h intext.h io.h memory.h gc.h major_gc.h minor_gc.h osdeps.h \ prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ version.h str.pic.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ diff --git a/byterun/Makefile b/byterun/Makefile index 9ee6a69d0d..1515294519 100644 --- a/byterun/Makefile +++ b/byterun/Makefile @@ -22,14 +22,10 @@ OBJS=$(COMMONOBJS) unix.o main.o DOBJS=$(OBJS:.o=.d.o) instrtrace.d.o PICOBJS=$(OBJS:.o=.pic.o) -#ifeq ($(SUPPORTS_SHARED_LIBRARIES),true) +SHARED_LIBS_TMP=$(SUPPORTS_SHARED_LIBRARIES:%false=) +SHARED_LIBS_DEPS=$(SHARED_LIBS_TMP:%true=libcamlrun_shared.so) -all:: libcamlrun_shared.so - -install:: - cp libcamlrun_shared.so $(LIBDIR)/libcamlrun_shared.so - -#endif +all:: $(SHARED_LIBS_DEPS) ocamlrun$(EXE): libcamlrun.a prims.o $(MKEXE) $(BYTECCLINKOPTS) -o ocamlrun$(EXE) \ @@ -48,7 +44,15 @@ libcamlrund.a: $(DOBJS) $(RANLIB) libcamlrund.a libcamlrun_shared.so: $(PICOBJS) - $(MKDLL) -o libcamlrun_shared.so $(PICOBJS) + $(MKDLL) -o libcamlrun_shared.so $(PICOBJS) $(BYTECCLIBS) + +install:: + if test -f libcamlrun_shared.so; then \ + cp libcamlrun_shared.so $(LIBDIR)/libcamlrun_shared.so; fi + +clean:: + rm -f libcamlrun_shared.so + .SUFFIXES: .d.o .pic.o diff --git a/byterun/Makefile.common b/byterun/Makefile.common index 2546cf661f..10fb34024f 100755 --- a/byterun/Makefile.common +++ b/byterun/Makefile.common @@ -86,7 +86,7 @@ jumptbl.h : instruct.h version.h : ../VERSION echo "#define OCAML_VERSION \"`head -1 ../VERSION`\"" > version.h -clean: +clean :: rm -f ocamlrun$(EXE) ocamlrund$(EXE) *.$(O) *.$(A) *.$(SO) rm -f primitives prims.c opnames.h jumptbl.h ld.conf rm -f version.h diff --git a/byterun/Makefile.nt b/byterun/Makefile.nt index 455de6fa6c..23fcde9338 100644 --- a/byterun/Makefile.nt +++ b/byterun/Makefile.nt @@ -22,10 +22,10 @@ OBJS=$(COMMONOBJS:.o=.$(O)) win32.$(O) main.$(O) DOBJS=$(OBJS:.$(O)=.$(DBGO)) instrtrace.$(DBGO) ocamlrun$(EXE): libcamlrun.$(A) prims.$(O) - $(MKEXE) -o ocamlrun$(EXE) prims.$(O) $(call SYSLIB,ws2_32) libcamlrun.$(A) + $(MKEXE) -o ocamlrun$(EXE) prims.$(O) $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrun.$(A) ocamlrund$(EXE): libcamlrund.$(A) prims.$(O) main.$(O) - $(MKEXE) -o ocamlrun$(EXE) $(BYTECCDBGCOMPOPTS) prims.$(O) $(call SYSLIB,ws2_32) libcamlrund.$(A) + $(MKEXE) -o ocamlrun$(EXE) $(BYTECCDBGCOMPOPTS) prims.$(O) $(call SYSLIB,ws2_32) $(EXTRALIBS) libcamlrund.$(A) libcamlrun.$(A): $(OBJS) $(call MKLIB,libcamlrun.$(A),$(OBJS)) diff --git a/byterun/config.h b/byterun/config.h index 00c70978f1..57d7947b90 100644 --- a/byterun/config.h +++ b/byterun/config.h @@ -107,7 +107,7 @@ typedef struct { uint32 l, h; } uint64, int64; /* Memory model parameters */ /* The size of a page for memory management (in bytes) is [1 << Page_log]. - It must be a multiple of [sizeof (value)] and >= 8. */ + It must be a multiple of [sizeof (value)] and >= 8 and <= 20. */ #define Page_log 12 /* A page is 4 kilobytes. */ /* Initial size of stack (bytes). */ diff --git a/byterun/finalise.c b/byterun/finalise.c index 1e176dd170..6851558108 100644 --- a/byterun/finalise.c +++ b/byterun/finalise.c @@ -139,7 +139,7 @@ void caml_final_do_calls (void) -- to_do_hd->size; f = to_do_hd->item[to_do_hd->size]; running_finalisation_function = 1; - caml_callback (f.fun, f.val + f.offset); + caml_callback (f.fun, f.val + f.offset); /* FIXME PR#4742 */ running_finalisation_function = 0; } caml_gc_message (0x80, "Done calling finalisation functions.\n", 0); diff --git a/byterun/freelist.c b/byterun/freelist.c index a2a8a0fb0a..ab1d458ba2 100644 --- a/byterun/freelist.c +++ b/byterun/freelist.c @@ -13,6 +13,11 @@ /* $Id$ */ +#define FREELIST_DEBUG 0 +#if FREELIST_DEBUG +#include <stdio.h> +#endif + #include <string.h> #include "config.h" @@ -43,6 +48,7 @@ static struct { } sentinel = {0, Make_header (0, 0, Caml_blue), 0, 0}; #define Fl_head ((char *) (&(sentinel.first_bp))) +static char *fl_prev = Fl_head; /* Current allocation pointer. */ static char *fl_last = NULL; /* Last block in the list. Only valid just after [caml_fl_allocate] returns NULL. */ char *caml_fl_merge = Fl_head; /* Current insertion pointer. Managed @@ -57,13 +63,17 @@ static char *beyond = NULL; #define Next(b) (((block *) (b))->next_bp) +#define Policy_next_fit 0 +#define Policy_first_fit 1 +uintnat caml_allocation_policy = Policy_next_fit; +#define policy caml_allocation_policy + #ifdef DEBUG static void fl_check (void) { char *cur, *prev; - int merge_found = 0; + int prev_found = 0, flp_found = 0, merge_found = 0; uintnat size_found = 0; - int flp_found = 0; int sz = 0; prev = Fl_head; @@ -71,7 +81,8 @@ static void fl_check (void) while (cur != NULL){ size_found += Whsize_bp (cur); Assert (Is_in_heap (cur)); - if (Wosize_bp (cur) > sz){ + if (cur == fl_prev) prev_found = 1; + if (policy == Policy_first_fit && Wosize_bp (cur) > sz){ sz = Wosize_bp (cur); if (flp_found < flp_size){ Assert (Next (flp[flp_found]) == cur); @@ -84,7 +95,8 @@ static void fl_check (void) prev = cur; cur = Next (prev); } - Assert (flp_found == flp_size); + if (policy == Policy_next_fit) Assert (prev_found || fl_prev == Fl_head); + if (policy == Policy_first_fit) Assert (flp_found == flp_size); Assert (merge_found || caml_fl_merge == Fl_head); Assert (size_found == caml_fl_cur_size); } @@ -121,16 +133,19 @@ static char *allocate_block (mlsize_t wh_sz, int flpi, char *prev, char *cur) In case 0, it gives an invalid header to the block. The function calling [caml_fl_allocate] will overwrite it. */ Hd_op (cur) = Make_header (0, 0, Caml_white); - if (flpi + 1 < flp_size && flp[flpi + 1] == cur){ - flp[flpi + 1] = prev; - }else if (flpi == flp_size - 1){ - beyond = (prev == Fl_head) ? NULL : prev; - -- flp_size; + if (policy == Policy_first_fit){ + if (flpi + 1 < flp_size && flp[flpi + 1] == cur){ + flp[flpi + 1] = prev; + }else if (flpi == flp_size - 1){ + beyond = (prev == Fl_head) ? NULL : prev; + -- flp_size; + } } }else{ /* Case 2. */ caml_fl_cur_size -= wh_sz; Hd_op (cur) = Make_header (Wosize_hd (h) - wh_sz, 0, Caml_blue); } + if (policy == Policy_next_fit) fl_prev = prev; return cur + Bosize_hd (h) - Bsize_wsize (wh_sz); } @@ -145,124 +160,180 @@ char *caml_fl_allocate (mlsize_t wo_sz) mlsize_t sz, prevsz; Assert (sizeof (char *) == sizeof (value)); Assert (wo_sz >= 1); - /* Search in the flp array. */ - for (i = 0; i < flp_size; i++){ - sz = Wosize_bp (Next (flp[i])); - if (sz >= wo_sz){ - result = allocate_block (Whsize_wosize (wo_sz), i, flp[i], Next (flp[i])); - goto update_flp; + switch (policy){ + case Policy_next_fit: + Assert (fl_prev != NULL); + /* Search from [fl_prev] to the end of the list. */ + prev = fl_prev; + cur = Next (prev); + while (cur != NULL){ Assert (Is_in_heap (cur)); + if (Wosize_bp (cur) >= wo_sz){ + return allocate_block (Whsize_wosize (wo_sz), 0, prev, cur); + } + prev = cur; + cur = Next (prev); } - } - /* Extend the flp array. */ - if (flp_size == 0){ + fl_last = prev; + /* Search from the start of the list to [fl_prev]. */ prev = Fl_head; - prevsz = 0; - }else{ - prev = Next (flp[flp_size - 1]); - prevsz = Wosize_bp (prev); - if (beyond != NULL) prev = beyond; - } - while (flp_size < FLP_MAX){ cur = Next (prev); - if (cur == NULL){ - fl_last = prev; - beyond = (prev == Fl_head) ? NULL : prev; - return NULL; - }else{ - sz = Wosize_bp (cur); - if (sz > prevsz){ - flp[flp_size] = prev; - ++ flp_size; - if (sz >= wo_sz){ - beyond = cur; - i = flp_size - 1; - result = allocate_block (Whsize_wosize (wo_sz), flp_size - 1, prev, - cur); - goto update_flp; - } - prevsz = sz; + while (prev != fl_prev){ + if (Wosize_bp (cur) >= wo_sz){ + return allocate_block (Whsize_wosize (wo_sz), 0, prev, cur); } + prev = cur; + cur = Next (prev); } - prev = cur; - } - beyond = cur; - - /* The flp table is full. Do a slow first-fit search. */ - - if (beyond != NULL){ - prev = beyond; - }else{ - prev = flp[flp_size - 1]; - } - prevsz = Wosize_bp (Next (flp[FLP_MAX-1])); - Assert (prevsz < wo_sz); - cur = Next (prev); - while (cur != NULL){ - Assert (Is_in_heap (cur)); - sz = Wosize_bp (cur); - if (sz < prevsz){ - beyond = cur; - }else if (sz >= wo_sz){ - return allocate_block (Whsize_wosize (wo_sz), flp_size, prev, cur); + /* No suitable block was found. */ + return NULL; + break; + + case Policy_first_fit: { + /* Search in the flp array. */ + for (i = 0; i < flp_size; i++){ + sz = Wosize_bp (Next (flp[i])); + if (sz >= wo_sz){ +#if FREELIST_DEBUG + if (i > 5) fprintf (stderr, "FLP: found at %d size=%d\n", i, wo_sz); +#endif + result = allocate_block (Whsize_wosize (wo_sz), i, flp[i], Next(flp[i])); + goto update_flp; + } } - prev = cur; - cur = Next (prev); - } - fl_last = prev; - return NULL; - - update_flp: /* (i, sz) */ - /* The block at [i] was removed or reduced. Update the table. */ - Assert (0 <= i && i < flp_size + 1); - if (i < flp_size){ - if (i > 0){ - prevsz = Wosize_bp (Next (flp[i-1])); - }else{ + /* Extend the flp array. */ + if (flp_size == 0){ + prev = Fl_head; prevsz = 0; + }else{ + prev = Next (flp[flp_size - 1]); + prevsz = Wosize_bp (prev); + if (beyond != NULL) prev = beyond; } - if (i == flp_size - 1){ - if (Wosize_bp (Next (flp[i])) <= prevsz){ - beyond = Next (flp[i]); - -- flp_size; + while (flp_size < FLP_MAX){ + cur = Next (prev); + if (cur == NULL){ + fl_last = prev; + beyond = (prev == Fl_head) ? NULL : prev; + return NULL; }else{ - beyond = NULL; - } - }else{ - char *buf [FLP_MAX]; - int j = 0; - mlsize_t oldsz = sz; - - prev = flp[i]; - while (prev != flp[i+1]){ - cur = Next (prev); sz = Wosize_bp (cur); if (sz > prevsz){ - buf[j++] = prev; - prevsz = sz; - if (sz >= oldsz){ - Assert (sz == oldsz); - break; + flp[flp_size] = prev; + ++ flp_size; + if (sz >= wo_sz){ + beyond = cur; + i = flp_size - 1; +#if FREELIST_DEBUG + if (flp_size > 5){ + fprintf (stderr, "FLP: extended to %d\n", flp_size); + } +#endif + result = allocate_block (Whsize_wosize (wo_sz), flp_size - 1, prev, + cur); + goto update_flp; } + prevsz = sz; } - prev = cur; } - if (FLP_MAX >= flp_size + j - 1){ - memmove (&flp[i+j], &flp[i+1], sizeof (block *) * (flp_size - i - 1)); - memmove (&flp[i], &buf[0], sizeof (block *) * j); - flp_size += j - 1; + prev = cur; + } + beyond = cur; + + /* The flp table is full. Do a slow first-fit search. */ +#if FREELIST_DEBUG + fprintf (stderr, "FLP: table is full -- slow first-fit\n"); +#endif + if (beyond != NULL){ + prev = beyond; + }else{ + prev = flp[flp_size - 1]; + } + prevsz = Wosize_bp (Next (flp[FLP_MAX-1])); + Assert (prevsz < wo_sz); + cur = Next (prev); + while (cur != NULL){ + Assert (Is_in_heap (cur)); + sz = Wosize_bp (cur); + if (sz < prevsz){ + beyond = cur; + }else if (sz >= wo_sz){ + return allocate_block (Whsize_wosize (wo_sz), flp_size, prev, cur); + } + prev = cur; + cur = Next (prev); + } + fl_last = prev; + return NULL; + + update_flp: /* (i, sz) */ + /* The block at [i] was removed or reduced. Update the table. */ + Assert (0 <= i && i < flp_size + 1); + if (i < flp_size){ + if (i > 0){ + prevsz = Wosize_bp (Next (flp[i-1])); + }else{ + prevsz = 0; + } + if (i == flp_size - 1){ + if (Wosize_bp (Next (flp[i])) <= prevsz){ + beyond = Next (flp[i]); + -- flp_size; + }else{ + beyond = NULL; + } }else{ - if (FLP_MAX > i + j){ - memmove (&flp[i+j], &flp[i+1], sizeof (block *) * (FLP_MAX - i - j)); - memmove (&flp[i], &buf[0], sizeof (block *) * j); + char *buf [FLP_MAX]; + int j = 0; + mlsize_t oldsz = sz; + + prev = flp[i]; + while (prev != flp[i+1]){ + cur = Next (prev); + sz = Wosize_bp (cur); + if (sz > prevsz){ + buf[j++] = prev; + prevsz = sz; + if (sz >= oldsz){ + Assert (sz == oldsz); + break; + } + } + prev = cur; + } +#if FREELIST_DEBUG + if (j > 2) fprintf (stderr, "FLP: update; buf size = %d\n", j); +#endif + if (FLP_MAX >= flp_size + j - 1){ + if (j != 1){ + memmove (&flp[i+j], &flp[i+1], sizeof (block *) * (flp_size-i-1)); + } + if (j > 0) memmove (&flp[i], &buf[0], sizeof (block *) * j); + flp_size += j - 1; }else{ - memmove (&flp[i], &buf[0], sizeof (block *) * (FLP_MAX - i)); + if (FLP_MAX > i + j){ + if (j != 1){ + memmove (&flp[i+j], &flp[i+1], sizeof (block *) * (FLP_MAX-i-j)); + } + if (j > 0) memmove (&flp[i], &buf[0], sizeof (block *) * j); + }else{ + if (i != FLP_MAX){ + memmove (&flp[i], &buf[0], sizeof (block *) * (FLP_MAX - i)); + } + } + flp_size = FLP_MAX - 1; + beyond = Next (flp[FLP_MAX - 1]); } - flp_size = FLP_MAX - 1; - beyond = Next (flp[FLP_MAX - 1]); } } + return result; + } + break; + + default: + Assert (0); /* unknown policy */ + break; } - return result; + return NULL; /* NOT REACHED */ } static char *last_fragment; @@ -291,7 +362,17 @@ static void truncate_flp (char *changed) void caml_fl_reset (void) { Next (Fl_head) = NULL; - truncate_flp (Fl_head); + switch (policy){ + case Policy_next_fit: + fl_prev = Fl_head; + break; + case Policy_first_fit: + truncate_flp (Fl_head); + break; + default: + Assert (0); + break; + } caml_fl_cur_size = 0; caml_fl_init_merge (); } @@ -316,7 +397,7 @@ char *caml_fl_merge_block (char *bp) Assert (prev < bp || prev == Fl_head); Assert (cur > bp || cur == NULL); - truncate_flp (prev); + if (policy == Policy_first_fit) truncate_flp (prev); /* If [last_fragment] and [bp] are adjacent, merge them. */ if (last_fragment == Hp_bp (bp)){ @@ -338,6 +419,7 @@ char *caml_fl_merge_block (char *bp) if (Wosize_hd (hd) + cur_whsz <= Max_wosize){ Next (prev) = next_cur; + if (policy == Policy_next_fit && fl_prev == cur) fl_prev = prev; hd = Make_header (Wosize_hd (hd) + cur_whsz, 0, Caml_blue); Hd_bp (bp) = hd; adj = bp + Bosize_hd (hd); @@ -395,7 +477,9 @@ void caml_fl_add_blocks (char *bp) if (fl_last == caml_fl_merge && bp < caml_gc_sweep_hp){ caml_fl_merge = (char *) Field (bp, 1); } - if (flp_size < FLP_MAX) flp [flp_size++] = fl_last; + if (policy == Policy_first_fit && flp_size < FLP_MAX){ + flp [flp_size++] = fl_last; + } }else{ char *cur, *prev; @@ -415,7 +499,7 @@ void caml_fl_add_blocks (char *bp) if (prev == caml_fl_merge && bp < caml_gc_sweep_hp){ caml_fl_merge = (char *) Field (bp, 1); } - truncate_flp (bp); + if (policy == Policy_first_fit) truncate_flp (bp); } } @@ -442,3 +526,20 @@ void caml_make_free_blocks (value *p, mlsize_t size, int do_merge) p += sz; } } + +void caml_set_allocation_policy (uintnat p) +{ + switch (p){ + case Policy_next_fit: + fl_prev = Fl_head; + break; + case Policy_first_fit: + flp_size = 0; + beyond = NULL; + break; + default: + Assert (0); + break; + } + policy = p; +} diff --git a/byterun/freelist.h b/byterun/freelist.h index 823748548f..8db168e9b5 100644 --- a/byterun/freelist.h +++ b/byterun/freelist.h @@ -30,6 +30,7 @@ void caml_fl_reset (void); char *caml_fl_merge_block (char *); void caml_fl_add_blocks (char *); void caml_make_free_blocks (value *, mlsize_t, int); +void caml_set_allocation_policy (uintnat); #endif /* CAML_FREELIST_H */ diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index 6a69cc1347..ec9c82ab12 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -17,6 +17,7 @@ #include "compact.h" #include "custom.h" #include "finalise.h" +#include "freelist.h" #include "gc.h" #include "gc_ctrl.h" #include "major_gc.h" @@ -41,8 +42,9 @@ intnat caml_stat_minor_collections = 0, caml_stat_heap_chunks = 0; extern asize_t caml_major_heap_increment; /* bytes; see major_gc.c */ -extern uintnat caml_percent_free; /* see major_gc.c */ -extern uintnat caml_percent_max; /* see compact.c */ +extern uintnat caml_percent_free; /* see major_gc.c */ +extern uintnat caml_percent_max; /* see compact.c */ +extern uintnat caml_allocation_policy; /* see freelist.c */ #define Next(hp) ((hp) + Bhsize_hp (hp)) @@ -306,7 +308,7 @@ CAMLprim value caml_gc_get(value v) CAMLparam0 (); /* v is ignored */ CAMLlocal1 (res); - res = caml_alloc_tuple (6); + res = caml_alloc_tuple (7); Store_field (res, 0, Val_long (Wsize_bsize (caml_minor_heap_size))); /* s */ Store_field (res, 1,Val_long(Wsize_bsize(caml_major_heap_increment)));/* i */ Store_field (res, 2, Val_long (caml_percent_free)); /* o */ @@ -317,6 +319,7 @@ CAMLprim value caml_gc_get(value v) #else Store_field (res, 5, Val_long (0)); #endif + Store_field (res, 6, Val_long (caml_allocation_policy)); /* a */ CAMLreturn (res); } @@ -347,11 +350,21 @@ static intnat norm_minsize (intnat s) return s; } +static intnat norm_policy (intnat p) +{ + if (p >= 0 && p <= 1){ + return p; + }else{ + return 1; + } +} + CAMLprim value caml_gc_set(value v) { uintnat newpf, newpm; asize_t newheapincr; asize_t newminsize; + uintnat newpolicy; caml_verb_gc = Long_val (Field (v, 3)); @@ -377,6 +390,11 @@ CAMLprim value caml_gc_set(value v) caml_gc_message (0x20, "New heap increment size: %luk bytes\n", caml_major_heap_increment/1024); } + newpolicy = norm_policy (Long_val (Field (v, 6))); + if (newpolicy != caml_allocation_policy){ + caml_gc_message (0x20, "New allocation policy: %d\n", newpolicy); + caml_set_allocation_policy (newpolicy); + } /* Minor heap size comes last because it will trigger a minor collection (thus invalidating [v]) and it can raise [Out_of_memory]. */ @@ -471,4 +489,6 @@ void caml_init_gc (uintnat minor_size, uintnat major_size, caml_gc_message (0x20, "Initial max overhead: %lu%%\n", caml_percent_max); caml_gc_message (0x20, "Initial heap increment: %luk bytes\n", caml_major_heap_increment / 1024); + caml_gc_message (0x20, "Initial allocation policy: %d\n", + caml_allocation_policy); } diff --git a/byterun/globroots.c b/byterun/globroots.c index 5de3d1315b..e4fec33287 100644 --- a/byterun/globroots.c +++ b/byterun/globroots.c @@ -232,6 +232,28 @@ CAMLexport void caml_modify_generational_global_root(value *r, value newval) caml_delete_global_root(&caml_global_roots_old, r); caml_insert_global_root(&caml_global_roots_young, r); } + /* PR#4704 */ + else if (!Is_block(oldval) && Is_block(newval)) { + /* The previous value in the root was unboxed but now it is boxed. + The root won't appear in any of the root lists thus far (by virtue + of the operation of [caml_register_generational_global_root]), so we + need to make sure it gets in, or else it will never be scanned. */ + if (Is_young(newval)) + caml_insert_global_root(&caml_global_roots_young, r); + else if (Is_in_heap(newval)) + caml_insert_global_root(&caml_global_roots_old, r); + } + else if (Is_block(oldval) && !Is_block(newval)) { + /* The previous value in the root was boxed but now it is unboxed, so + the root should be removed. If [oldval] is young, this will happen + anyway at the next minor collection, but it is safer to delete it + here. */ + if (Is_young(oldval)) + caml_delete_global_root(&caml_global_roots_young, r); + else if (Is_in_heap(oldval)) + caml_delete_global_root(&caml_global_roots_old, r); + } + /* end PR#4704 */ *r = newval; } diff --git a/byterun/int64_emul.h b/byterun/int64_emul.h index 04e38656f3..c0b7440baf 100644 --- a/byterun/int64_emul.h +++ b/byterun/int64_emul.h @@ -96,8 +96,9 @@ static int64 I64_mul(int64 x, int64 y) } #define I64_is_zero(x) (((x).l | (x).h) == 0) - #define I64_is_negative(x) ((int32) (x).h < 0) +#define I64_is_min_int(x) ((x).l == 0 && (x).h = 0x80000000U) +#define I64_is_minus_one(x) (((x).l & (x).h) == 0xFFFFFFFFU) /* Bitwise operations */ static int64 I64_and(int64 x, int64 y) diff --git a/byterun/int64_native.h b/byterun/int64_native.h index f5bef4a6f4..9c07909701 100644 --- a/byterun/int64_native.h +++ b/byterun/int64_native.h @@ -29,6 +29,9 @@ #define I64_mul(x,y) ((x) * (y)) #define I64_is_zero(x) ((x) == 0) #define I64_is_negative(x) ((x) < 0) +#define I64_is_min_int(x) ((x) == ((int64)1 << 63)) +#define I64_is_minus_one(x) ((x) == -1) + #define I64_div(x,y) ((x) / (y)) #define I64_mod(x,y) ((x) % (y)) #define I64_udivmod(x,y,quo,rem) \ diff --git a/byterun/interp.c b/byterun/interp.c index 2d65b6af5b..bbd8367e8a 100644 --- a/byterun/interp.c +++ b/byterun/interp.c @@ -113,7 +113,7 @@ sp is a local copy of the global variable caml_extern_sp. */ For GCC, I have hand-assigned hardware registers for several architectures. */ -#if defined(__GNUC__) && !defined(__INTEL_COMPILER) && !defined(DEBUG) +#if defined(__GNUC__) && !defined(DEBUG) && !defined(__INTEL_COMPILER) && !defined(__llvm__) #ifdef __mips__ #define PC_REG asm("$16") #define SP_REG asm("$17") diff --git a/byterun/ints.c b/byterun/ints.c index ed18e6f446..5fc15c6264 100644 --- a/byterun/ints.c +++ b/byterun/ints.c @@ -248,23 +248,31 @@ CAMLprim value caml_int32_mul(value v1, value v2) CAMLprim value caml_int32_div(value v1, value v2) { + int32 dividend = Int32_val(v1); int32 divisor = Int32_val(v2); if (divisor == 0) caml_raise_zero_divide(); + /* PR#4740: on some processors, division crashes on overflow. + Implement the same behavior as for type "int". */ + if (dividend == (1<<31) && divisor == -1) return v1; #ifdef NONSTANDARD_DIV_MOD - return caml_copy_int32(caml_safe_div(Int32_val(v1), divisor)); + return caml_copy_int32(caml_safe_div(dividend, divisor)); #else - return caml_copy_int32(Int32_val(v1) / divisor); + return caml_copy_int32(dividend / divisor); #endif } CAMLprim value caml_int32_mod(value v1, value v2) { + int32 dividend = Int32_val(v1); int32 divisor = Int32_val(v2); if (divisor == 0) caml_raise_zero_divide(); + /* PR#4740: on some processors, modulus crashes if division overflows. + Implement the same behavior as for type "int". */ + if (dividend == (1<<31) && divisor == -1) return caml_copy_int32(0); #ifdef NONSTANDARD_DIV_MOD - return caml_copy_int32(caml_safe_mod(Int32_val(v1), divisor)); + return caml_copy_int32(caml_safe_mod(dividend, divisor)); #else - return caml_copy_int32(Int32_val(v1) % divisor); + return caml_copy_int32(dividend % divisor); #endif } @@ -430,15 +438,26 @@ CAMLprim value caml_int64_mul(value v1, value v2) CAMLprim value caml_int64_div(value v1, value v2) { + int64 dividend = Int64_val(v1); int64 divisor = Int64_val(v2); if (I64_is_zero(divisor)) caml_raise_zero_divide(); + /* PR#4740: on some processors, division crashes on overflow. + Implement the same behavior as for type "int". */ + if (I64_is_min_int(dividend) && I64_is_minus_one(divisor)) return v1; return caml_copy_int64(I64_div(Int64_val(v1), divisor)); } CAMLprim value caml_int64_mod(value v1, value v2) { + int64 dividend = Int64_val(v1); int64 divisor = Int64_val(v2); if (I64_is_zero(divisor)) caml_raise_zero_divide(); + /* PR#4740: on some processors, division crashes on overflow. + Implement the same behavior as for type "int". */ + if (I64_is_min_int(dividend) && I64_is_minus_one(divisor)) { + int64 zero = I64_literal(0,0); + return caml_copy_int64(zero); + } return caml_copy_int64(I64_mod(Int64_val(v1), divisor)); } @@ -650,25 +669,35 @@ CAMLprim value caml_nativeint_sub(value v1, value v2) CAMLprim value caml_nativeint_mul(value v1, value v2) { return caml_copy_nativeint(Nativeint_val(v1) * Nativeint_val(v2)); } +#define Nativeint_min_int ((intnat) 1 << (sizeof(intnat) * 8 - 1)) + CAMLprim value caml_nativeint_div(value v1, value v2) { + intnat dividend = Nativeint_val(v1); intnat divisor = Nativeint_val(v2); if (divisor == 0) caml_raise_zero_divide(); + /* PR#4740: on some processors, modulus crashes if division overflows. + Implement the same behavior as for type "int". */ + if (dividend == Nativeint_min_int && divisor == -1) return v1; #ifdef NONSTANDARD_DIV_MOD - return caml_copy_nativeint(caml_safe_div(Nativeint_val(v1), divisor)); + return caml_copy_nativeint(caml_safe_div(dividend, divisor)); #else - return caml_copy_nativeint(Nativeint_val(v1) / divisor); + return caml_copy_nativeint(dividend / divisor); #endif } CAMLprim value caml_nativeint_mod(value v1, value v2) { + intnat dividend = Nativeint_val(v1); intnat divisor = Nativeint_val(v2); if (divisor == 0) caml_raise_zero_divide(); + /* PR#4740: on some processors, modulus crashes if division overflows. + Implement the same behavior as for type "int". */ + if (dividend == Nativeint_min_int && divisor == -1) return caml_copy_nativeint(0); #ifdef NONSTANDARD_DIV_MOD - return caml_copy_nativeint(caml_safe_mod(Nativeint_val(v1), divisor)); + return caml_copy_nativeint(caml_safe_mod(dividend, divisor)); #else - return caml_copy_nativeint(Nativeint_val(v1) % divisor); + return caml_copy_nativeint(dividend % divisor); #endif } diff --git a/byterun/major_gc.c b/byterun/major_gc.c index 312d9a4a24..1298498f48 100644 --- a/byterun/major_gc.c +++ b/byterun/major_gc.c @@ -358,13 +358,25 @@ intnat caml_major_collection_slice (intnat howmuch) MW = caml_stat_heap_size * 100 / (100 + caml_percent_free) Amount of sweeping work for the GC cycle: SW = caml_stat_heap_size - Amount of marking work for this slice: - MS = P * MW - MS = P * caml_stat_heap_size * 100 / (100 + caml_percent_free) - Amount of sweeping work for this slice: - SS = P * SW - SS = P * caml_stat_heap_size - This slice will either mark 2*MS words or sweep 2*SS words. + + In order to finish marking with a non-empty free list, we will + use 40% of the time for marking, and 60% for sweeping. + + If TW is the total work for this cycle, + MW = 40/100 * TW + SW = 60/100 * TW + + Amount of work to do for this slice: + W = P * TW + + Amount of marking work for a marking slice: + MS = P * MW / (40/100) + MS = P * caml_stat_heap_size * 250 / (100 + caml_percent_free) + Amount of sweeping work for a sweeping slice: + SS = P * SW / (60/100) + SS = P * caml_stat_heap_size * 5 / 3 + + This slice will either mark MS words or sweep SS words. */ if (caml_gc_phase == Phase_idle) start_cycle (); @@ -391,10 +403,10 @@ intnat caml_major_collection_slice (intnat howmuch) (uintnat) (p * 1000000)); if (caml_gc_phase == Phase_mark){ - computed_work = 2 * (intnat) (p * Wsize_bsize (caml_stat_heap_size) * 100 - / (100 + caml_percent_free)); + computed_work = (intnat) (p * Wsize_bsize (caml_stat_heap_size) * 250 + / (100 + caml_percent_free)); }else{ - computed_work = 2 * (intnat) (p * Wsize_bsize (caml_stat_heap_size)); + computed_work = (intnat) (p * Wsize_bsize (caml_stat_heap_size) * 5 / 3); } caml_gc_message (0x40, "ordered work = %ld words\n", howmuch); caml_gc_message (0x40, "computed work = %ld words\n", computed_work); diff --git a/byterun/memory.c b/byterun/memory.c index 0141517bff..e34f15a806 100644 --- a/byterun/memory.c +++ b/byterun/memory.c @@ -34,7 +34,10 @@ extern uintnat caml_percent_free; /* major_gc.c */ #define Page(p) ((uintnat) (p) >> Page_log) #define Page_mask ((uintnat) -1 << Page_log) -/* The page table is represented sparsely as a hash table +#ifdef ARCH_SIXTYFOUR + +/* 64-bit implementation: + The page table is represented sparsely as a hash table with linear probing */ struct page_table { @@ -161,6 +164,38 @@ static int caml_page_table_modify(uintnat page, int toclear, int toset) return 0; } +#else + +/* 32-bit implementation: + The page table is represented as a 2-level array of unsigned char */ + +CAMLexport unsigned char * caml_page_table[Pagetable1_size]; +static unsigned char caml_page_table_empty[Pagetable2_size] = { 0, }; + +int caml_page_table_initialize(mlsize_t bytesize) +{ + int i; + for (i = 0; i < Pagetable1_size; i++) + caml_page_table[i] = caml_page_table_empty; + return 0; +} + +static int caml_page_table_modify(uintnat page, int toclear, int toset) +{ + uintnat i = Pagetable_index1(page); + uintnat j = Pagetable_index2(page); + + if (caml_page_table[i] == caml_page_table_empty) { + unsigned char * new_tbl = calloc(Pagetable2_size, 1); + if (new_tbl == 0) return -1; + caml_page_table[i] = new_tbl; + } + caml_page_table[i][j] = (caml_page_table[i][j] & ~toclear) | toset; + return 0; +} + +#endif + int caml_page_table_add(int kind, void * start, void * end) { uintnat pstart = (uintnat) start & Page_mask; diff --git a/byterun/memory.h b/byterun/memory.h index d7a07f6510..f8fb8ca2ba 100644 --- a/byterun/memory.h +++ b/byterun/memory.h @@ -55,13 +55,34 @@ color_t caml_allocation_color (void *hp); #define In_static_data 4 #define In_code_area 8 +#ifdef ARCH_SIXTYFOUR + +/* 64 bits: Represent page table as a sparse hash table */ +int caml_page_table_lookup(void * addr); #define Classify_addr(a) (caml_page_table_lookup((void *)(a))) + +#else + +/* 32 bits: Represent page table as a 2-level array */ +#define Pagetable2_log 11 +#define Pagetable2_size (1 << Pagetable2_log) +#define Pagetable1_log (Page_log + Pagetable2_log) +#define Pagetable1_size (1 << (32 - Pagetable1_log)) +CAMLextern unsigned char * caml_page_table[Pagetable1_size]; + +#define Pagetable_index1(a) (((uintnat)(a)) >> Pagetable1_log) +#define Pagetable_index2(a) \ + ((((uintnat)(a)) >> Page_log) & (Pagetable2_size - 1)) +#define Classify_addr(a) \ + caml_page_table[Pagetable_index1(a)][Pagetable_index2(a)] + +#endif + #define Is_in_value_area(a) \ (Classify_addr(a) & (In_heap | In_young | In_static_data)) #define Is_in_heap(a) (Classify_addr(a) & In_heap) #define Is_in_heap_or_young(a) (Classify_addr(a) & (In_heap | In_young)) -int caml_page_table_lookup(void * addr); int caml_page_table_add(int kind, void * start, void * end); int caml_page_table_remove(int kind, void * start, void * end); int caml_page_table_initialize(mlsize_t bytesize); diff --git a/byterun/startup.c b/byterun/startup.c index 40db222224..34d6f315c9 100644 --- a/byterun/startup.c +++ b/byterun/startup.c @@ -35,6 +35,7 @@ #include "exec.h" #include "fail.h" #include "fix_code.h" +#include "freelist.h" #include "gc_ctrl.h" #include "instrtrace.h" #include "interp.h" @@ -298,6 +299,7 @@ static void scanmult (char *opt, uintnat *var) static void parse_camlrunparam(void) { char *opt = getenv ("OCAMLRUNPARAM"); + uintnat p; if (opt == NULL) opt = getenv ("CAMLRUNPARAM"); @@ -313,6 +315,7 @@ static void parse_camlrunparam(void) case 'v': scanmult (opt, &caml_verb_gc); break; case 'b': caml_record_backtrace(Val_true); break; case 'p': caml_parser_trace = 1; break; + case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break; } } } @@ -473,4 +476,3 @@ CAMLexport void caml_startup_code( if (Is_exception_result(res)) caml_fatal_uncaught_exception(Extract_exception(res)); } - diff --git a/byterun/unix.c b/byterun/unix.c index b0e606ccc7..6143a565cc 100644 --- a/byterun/unix.c +++ b/byterun/unix.c @@ -190,7 +190,7 @@ void * caml_dlsym(void * handle, char * name) void * caml_globalsym(char * name) { - return flexdll_dlsym(flexdll_dlopen(NULL,0,1), name); + return flexdll_dlsym(flexdll_dlopen(NULL,0), name); } char * caml_dlerror(void) diff --git a/config/Makefile.mingw b/config/Makefile.mingw index a3da402837..3e755f99a6 100644 --- a/config/Makefile.mingw +++ b/config/Makefile.mingw @@ -149,8 +149,7 @@ BNG_ASM_LEVEL=1 # There must be no spaces or special characters in $(TK_ROOT) TK_ROOT=c:/tcl TK_DEFS=-I$(TK_ROOT)/include -TK_LINK=$(TK_ROOT)/bin/tk83.dll $(TK_ROOT)/bin/tcl83.dll -lws2_32 -#TK_LINK=$(TK_ROOT)/lib/tk84.lib $(TK_ROOT)/lib/tcl84.lib -lws2_32 +TK_LINK=$(TK_ROOT)/bin/tk84.dll $(TK_ROOT)/bin/tcl84.dll -lws2_32 ############# Aliases for common commands diff --git a/config/Makefile.msvc b/config/Makefile.msvc index d932e87973..c9a42b6212 100644 --- a/config/Makefile.msvc +++ b/config/Makefile.msvc @@ -150,13 +150,12 @@ TK_ROOT=c:/tcl TK_DEFS=-I$(TK_ROOT)/include # The following definition avoids hard-wiring $(TK_ROOT) in the libraries # produced by OCaml, and is therefore required for binary distribution -# of these libraries. However, $(TK_ROOT) must be added to the LIB +# of these libraries. However, $(TK_ROOT)/lib must be added to the LIB # environment variable, as described in README.win32. -#TK_LINK=tk84.lib tcl84.lib ws2_32.lib -TK_LINK=tk83.lib tcl83.lib ws2_32.lib +TK_LINK=tk84.lib tcl84.lib ws2_32.lib # An alternative definition that avoids mucking with the LIB variable, # but hard-wires the Tcl/Tk location in the binaries -# TK_LINK=$(TK_ROOT)/tk83.lib $(TK_ROOT)/tcl83.lib ws2_32.lib +# TK_LINK=$(TK_ROOT)/tk84.lib $(TK_ROOT)/tcl84.lib ws2_32.lib ############# Aliases for common commands @@ -294,8 +294,10 @@ case "$bytecc,$host" in bytecccompopts="-fno-defer-pop -no-cpp-precomp $gcc_warnings" mathlib="" # Tell gcc that we can use 32-bit code addresses for threaded code - # even if we compile in 64-bit mode - echo "#define ARCH_CODE32" >> m.h;; + # unless we are compiled for a shared library (-fPIC option) + echo "#ifndef __PIC__" >> m.h + echo "# define ARCH_CODE32" >> m.h + echo "#endif" >> m.h;; *,*-*-beos*) bytecccompopts="-fno-defer-pop $gcc_warnings" # No -lm library @@ -337,8 +339,13 @@ case "$bytecc,$host" in dllccompopts="-D_WIN32 -DCAML_DLL" flexlink="flexlink -chain cygwin -merge-manifest" flexdir=`$flexlink -where | dos2unix` - iflexdir="-I\"$flexdir\"" - mkexe="$flexlink -exe" + if test -z "$flexdir"; then + echo "flexlink not found: native shared libraries won't be available" + withsharedlibs=no + else + iflexdir="-I\"$flexdir\"" + mkexe="$flexlink -exe" + fi exe=".exe" ostype="Cygwin";; gcc*,x86_64-*-linux*) @@ -600,20 +607,13 @@ if test $withsharedlibs = "yes"; then mksharedlibrpath="-rpath " shared_libraries_supported=true;; i[3456]86-*-darwin*) - dyld=ld - if test -f /usr/bin/ld_classic; then - # The new linker in Mac OS X 10.5 does not support read_only_relocs - # dyld=/usr/bin/ld_classic XXX FIXME incompatible with X11 libs - : - fi - mksharedlib="$dyld -bundle -flat_namespace -undefined suppress -read_only_relocs suppress" + mksharedlib="$bytecc -bundle -flat_namespace -undefined suppress -read_only_relocs suppress" bytecccompopts="$dl_defs $bytecccompopts" dl_needs_underscore=false shared_libraries_supported=true;; *-apple-darwin*) mksharedlib="$bytecc -bundle -flat_namespace -undefined suppress" bytecccompopts="$dl_defs $bytecccompopts" - #sharedcccompopts="-fnocommon" dl_needs_underscore=false shared_libraries_supported=true;; m88k-*-openbsd*) @@ -656,10 +656,18 @@ case "$host" in i[3456]86-*-linux*) arch=i386; system=linux_`sh ./runtest elf.c`;; i[3456]86-*-*bsd*) arch=i386; system=bsd_`sh ./runtest elf.c`;; i[3456]86-*-nextstep*) arch=i386; system=nextstep;; - i[3456]86-*-solaris*) arch=i386; system=solaris;; + i[3456]86-*-solaris*) if $arch64; then + arch=amd64; system=solaris + else + arch=i386; system=solaris + fi;; i[3456]86-*-beos*) arch=i386; system=beos;; i[3456]86-*-cygwin*) arch=i386; system=cygwin;; - i[3456]86-*-darwin*) arch=i386; system=macosx;; + i[3456]86-*-darwin*) if $arch64; then + arch=amd64; system=macosx + else + arch=i386; system=macosx + fi;; i[3456]86-*-gnu*) arch=i386; system=gnu;; mips-*-irix6*) arch=mips; system=irix;; hppa1.1-*-hpux*) arch=hppa; system=hpux;; @@ -681,6 +689,7 @@ case "$host" in x86_64-*-freebsd*) arch=amd64; system=freebsd;; x86_64-*-netbsd*) arch=amd64; system=netbsd;; x86_64-*-openbsd*) arch=amd64; system=openbsd;; + x86_64-*-darwin9.5) arch=amd64; system=macosx;; esac # Some platforms exist both in 32-bit and 64-bit variants, not distinguished @@ -719,6 +728,8 @@ case "$arch,$nativecc,$system,$host_type" in *,*,rhapsody,*) nativecccompopts="$gcc_warnings -DDARWIN_VERSION_6 $dl_defs" if $arch64; then partialld="ld -r -arch ppc64"; fi;; *,gcc*,cygwin,*) nativecccompopts="$gcc_warnings -U_WIN32";; + amd64,gcc*,macosx,*) partialld="ld -r -arch x86_64";; + amd64,gcc*,solaris,*) partialld="ld -r -m elf_x86_64";; *,gcc*,*,*) nativecccompopts="$gcc_warnings";; esac @@ -730,6 +741,10 @@ case "$arch,$model,$system" in asppprofflags='-pg -DPROFILING';; alpha,*,*) as='as' aspp='gcc -c';; + amd64,*,macosx) as='as -arch x86_64' + aspp='gcc -arch x86_64 -c';; + amd64,*,solaris) as='as --64' + aspp='gcc -m64 -c';; amd64,*,*) as='as' aspp='gcc -c';; arm,*,*) as='as'; @@ -768,6 +783,7 @@ case "$arch,$model,$system" in i386,*,linux_elf) profiling='prof';; i386,*,gnu) profiling='prof';; i386,*,bsd_elf) profiling='prof';; + amd64,*,macosx) profiling='prof';; i386,*,macosx) profiling='prof';; sparc,*,solaris) profiling='prof' @@ -1129,7 +1145,7 @@ fi # Determine if system stack overflows can be detected case "$arch,$system" in - i386,linux_elf|amd64,linux|power,rhapsody|i386,macosx) + i386,linux_elf|amd64,linux|power,rhapsody|amd64,macosx|i386,macosx|amd64,macosx) echo "System stack overflow can be detected." echo "#define HAS_STACK_OVERFLOW_DETECTION" >> s.h;; *) @@ -1138,23 +1154,24 @@ esac # Determine the target architecture for the "num" library -#case "$host" in -# alpha*-*-*) bng_arch=alpha; bng_asm_level=1;; -# i[3456]86-*-*) bng_arch=ia32 -# if sh ./trycompile ia32sse2.c -# then bng_asm_level=2 -# else bng_asm_level=1 -# fi;; -# mips-*-*) bng_arch=mips; bng_asm_level=1;; -# powerpc-*-*) bng_arch=ppc; bng_asm_level=1;; -# sparc*-*-*) bng_arch=sparc; bng_asm_level=1;; -# x86_64-*-*) bng_arch=amd64; bng_asm_level=1;; -# *) bng_arch=generic; bng_asm_level=0;; +#case "$arch" in +# alpha) bng_arch=alpha; bng_asm_level=1;; +# i386) bng_arch=ia32 +# if sh ./trycompile ia32sse2.c +# then bng_asm_level=2 +# else bng_asm_level=1 +# fi;; +# mips) bng_arch=mips; bng_asm_level=1;; +# power) bng_arch=ppc; bng_asm_level=1;; +# sparc) bng_arch=sparc; bng_asm_level=1;; +# amd64) bng_arch=amd64; bng_asm_level=1;; +# *) bng_arch=generic; bng_asm_level=0;; #esac # #echo "BNG_ARCH=$bng_arch" >> Makefile #echo "BNG_ASM_LEVEL=$bng_asm_level" >> Makefile + # Determine if the bytecode thread library is supported if test "$has_select" = "yes" \ @@ -1220,6 +1237,12 @@ x11_link="not found" for dir in \ $x11_include_dir \ \ + /usr/X11R7/include \ + /usr/include/X11R7 \ + /usr/local/X11R7/include \ + /usr/local/include/X11R7 \ + /opt/X11R7/include \ + \ /usr/X11R6/include \ /usr/include/X11R6 \ /usr/local/X11R6/include \ diff --git a/driver/main.ml b/driver/main.ml index 8c90134542..786ee8f5c1 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -97,7 +97,7 @@ module Options = Main_args.Make_options (struct let _a = set make_archive let _annot = set annotations let _c = set compile_only - let _cc s = c_compiler := s + let _cc s = c_compiler := Some s let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs let _ccopt s = ccopts := s :: !ccopts let _config = show_config @@ -164,9 +164,13 @@ let main () = Arg.parse Options.list anonymous usage; if List.length (List.filter (fun x -> !x) - [make_archive;make_package;compile_only;output_c_object]) > 1 + [make_archive;make_package;compile_only;output_c_object]) + > 1 then - fatal "Please specify at most one of -pack, -a, -c, -output-obj"; + if !print_types then + fatal "Option -i is incompatible with -pack, -a, -output-obj" + else + fatal "Please specify at most one of -pack, -a, -c, -output-obj"; if !make_archive then begin Compile.init_path(); diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 9c9aa857d0..662f4526e5 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -115,6 +115,8 @@ let implementation ppf sourcefile outputprefix = let inputfile = Pparse.preprocess sourcefile in let env = initial_env() in Compilenv.reset ?packname:!Clflags.for_package modulename; + let cmxfile = outputprefix ^ ".cmx" in + let objfile = outputprefix ^ ext_obj in try if !Clflags.print_types then ignore( Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number @@ -131,12 +133,16 @@ let implementation ppf sourcefile outputprefix = +++ Simplif.simplify_lambda +++ print_if ppf Clflags.dump_lambda Printlambda.lambda ++ Asmgen.compile_implementation outputprefix ppf; - Compilenv.save_unit_info (outputprefix ^ ".cmx"); + Compilenv.save_unit_info cmxfile; end; Warnings.check_fatal (); - Pparse.remove_preprocessed inputfile + Pparse.remove_preprocessed inputfile; + Stypes.dump (outputprefix ^ ".annot"); with x -> + remove_file objfile; + remove_file cmxfile; Pparse.remove_preprocessed_if_ast inputfile; + Stypes.dump (outputprefix ^ ".annot"); raise x let c_file name = diff --git a/driver/optmain.ml b/driver/optmain.ml index 7d3048a58f..41ca120a95 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -96,7 +96,6 @@ let show_config () = let main () = native_code := true; - c_compiler := Config.native_c_compiler; let ppf = Format.err_formatter in try Arg.parse (Arch.command_line_options @ [ @@ -104,7 +103,7 @@ let main () = "-annot", Arg.Set annotations, " Save information in <filename>.annot"; "-c", Arg.Set compile_only, " Compile only (do not link)"; - "-cc", Arg.String(fun s -> c_compiler := s), + "-cc", Arg.String(fun s -> c_compiler := Some s), "<comp> Use <comp> as the C compiler and linker"; "-cclib", Arg.String(fun s -> ccobjs := Misc.rev_split_words s @ !ccobjs), diff --git a/emacs/caml-font.el b/emacs/caml-font.el index 299f1ce79c..eaf56a5d37 100644 --- a/emacs/caml-font.el +++ b/emacs/caml-font.el @@ -81,11 +81,12 @@ (cond (in-string 'font-lock-string-face) (in-comment - (goto-char start) - (cond - ((looking-at "(\\*\\*/\\*\\*)") 'caml-font-stop-face) - ((looking-at "(\\*\\*[^*]") 'caml-font-doccomment-face) - (t 'font-lock-comment-face)))))) + (save-excursion + (goto-char start) + (cond + ((looking-at "(\\*\\*/\\*\\*)") 'caml-font-stop-face) + ((looking-at "(\\*\\*[^*]") 'caml-font-doccomment-face) + (t 'font-lock-comment-face))))))) ;; font-lock commands are similar for caml-mode and inferior-caml-mode diff --git a/emacs/caml.el b/emacs/caml.el index 9eb728fa94..e116898beb 100644 --- a/emacs/caml.el +++ b/emacs/caml.el @@ -413,10 +413,10 @@ have caml-electric-indent on, which see.") ; backslash is an escape sequence (modify-syntax-entry ?\\ "\\" caml-mode-syntax-table) ; ( is first character of comment start - (modify-syntax-entry ?\( "()1" caml-mode-syntax-table) + (modify-syntax-entry ?\( "()1n" caml-mode-syntax-table) ; * is second character of comment start, ; and first character of comment end - (modify-syntax-entry ?* ". 23" caml-mode-syntax-table) + (modify-syntax-entry ?* ". 23n" caml-mode-syntax-table) ; ) is last character of comment end (modify-syntax-entry ?\) ")(4" caml-mode-syntax-table) ; backquote was a string-like delimiter (for character literals) @@ -793,7 +793,7 @@ variable caml-mode-indentation." ;; Hence we add a regexp. (defconst caml-error-regexp - "^[A-\377]+ \"\\([^\"\n]+\\)\", [A-\377]+ \\([0-9]+\\)[-,:]" + "^[ A-\377]+ \"\\([^\"\n]+\\)\", [A-\377]+ \\([0-9]+\\)[-,:]" "Regular expression matching the error messages produced by camlc.") (if (boundp 'compilation-error-regexp-alist) @@ -806,7 +806,7 @@ variable caml-mode-indentation." ;; A regexp to extract the range info (defconst caml-error-chars-regexp - ".*, .*, [A-\377]+ \\([0-9]+\\)-\\([0-9]+\\):" + ".*, .*, [A-\377]+ \\([0-9]+\\)-\\([0-9]+\\):?" "Regular expression extracting the character numbers from an error message produced by camlc.") @@ -818,7 +818,7 @@ from an error message produced by camlc.") (defun caml-string-to-int (x) (if (fboundp 'string-to-number) (string-to-number x) (string-to-int x))) -;;itz 04-21-96 somebody didn't get the documetation for next-error +;;itz 04-21-96 somebody didn't get the documentation for next-error ;;right. When the optional argument is a number n, it should move ;;forward n errors, not reparse. diff --git a/lex/.depend b/lex/.depend index 1910d9efb0..4b8ea24537 100644 --- a/lex/.depend +++ b/lex/.depend @@ -1,11 +1,13 @@ common.cmi: syntax.cmi lexgen.cmi compact.cmi: lexgen.cmi +cset.cmi: lexer.cmi: parser.cmi lexgen.cmi: syntax.cmi outputbis.cmi: syntax.cmi lexgen.cmi common.cmi output.cmi: syntax.cmi lexgen.cmi compact.cmi common.cmi parser.cmi: syntax.cmi syntax.cmi: cset.cmi +table.cmi: common.cmo: syntax.cmi lexgen.cmi common.cmi common.cmx: syntax.cmx lexgen.cmx common.cmi compact.cmo: table.cmi lexgen.cmi compact.cmi diff --git a/ocamldoc/.depend b/ocamldoc/.depend index f9db8e1aec..fd915bc54e 100644 --- a/ocamldoc/.depend +++ b/ocamldoc/.depend @@ -146,14 +146,6 @@ odoc_name.cmx: ../typing/path.cmx ../parsing/longident.cmx \ ../typing/ident.cmx odoc_name.cmi odoc_ocamlhtml.cmo: odoc_ocamlhtml.cmx: -odoc_opt.cmo: ../typing/typedtree.cmi odoc_texi.cmo odoc_messages.cmo \ - odoc_man.cmo odoc_latex.cmo odoc_info.cmi odoc_html.cmo odoc_global.cmi \ - odoc_dot.cmo odoc_args.cmi odoc_analyse.cmi ../utils/misc.cmi \ - ../utils/config.cmi ../utils/clflags.cmi -odoc_opt.cmx: ../typing/typedtree.cmx odoc_texi.cmx odoc_messages.cmx \ - odoc_man.cmx odoc_latex.cmx odoc_info.cmx odoc_html.cmx odoc_global.cmx \ - odoc_dot.cmx odoc_args.cmx odoc_analyse.cmx ../utils/misc.cmx \ - ../utils/config.cmx ../utils/clflags.cmx odoc_parameter.cmo: ../typing/types.cmi odoc_types.cmi odoc_parameter.cmx: ../typing/types.cmx odoc_types.cmx odoc_parser.cmo: odoc_types.cmi odoc_comments_global.cmi odoc_parser.cmi diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index b8cf983a00..e24c05ce8b 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -111,16 +111,17 @@ CMOFILES= odoc_config.cmo \ CMXFILES= $(CMOFILES:.cmo=.cmx) CMIFILES= $(CMOFILES:.cmo=.cmi) -EXECMOFILES=$(CMOFILES)\ - odoc_dag2html.cmo\ - odoc_to_text.cmo\ - odoc_ocamlhtml.cmo\ - odoc_html.cmo\ - odoc_man.cmo\ +EXECMOFILES=$(CMOFILES) \ + odoc_dag2html.cmo \ + odoc_to_text.cmo \ + odoc_ocamlhtml.cmo \ + odoc_html.cmo \ + odoc_man.cmo \ odoc_latex_style.cmo \ - odoc_latex.cmo\ - odoc_texi.cmo\ - odoc_dot.cmo + odoc_latex.cmo \ + odoc_texi.cmo \ + odoc_dot.cmo \ + odoc.cmo EXECMXFILES= $(EXECMOFILES:.cmo=.cmx) EXECMIFILES= $(EXECMOFILES:.cmo=.cmi) @@ -204,10 +205,10 @@ libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI) debug: make OCAMLPP="" -$(OCAMLDOC): $(EXECMOFILES) odoc.cmo - $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) odoc.cmo -$(OCAMLDOC_OPT): $(EXECMXFILES) odoc_opt.cmx - $(OCAMLOPT) -o $@ unix.cmxa str.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) odoc_opt.cmx +$(OCAMLDOC): $(EXECMOFILES) + $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) +$(OCAMLDOC_OPT): $(EXECMXFILES) + $(OCAMLOPT) -o $@ unix.cmxa str.cmxa dynlink.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) $(OCAMLDOC_LIBCMA): $(LIBCMOFILES) $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLCMOFILES) $(LIBCMOFILES) @@ -216,6 +217,10 @@ $(OCAMLDOC_LIBCMXA): $(LIBCMXFILES) manpages: stdlib_man/Pervasives.3o +dot: $(EXECMOFILES) + $(OCAMLDOC_RUN) -dot -dot-reduce -o ocamldoc.dot $(INCLUDES) \ + odoc*.ml + # Parsers and lexers dependencies : ################################### odoc_text_parser.ml: odoc_text_parser.mly diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt index 9957ce125a..c4f9e4b91c 100644 --- a/ocamldoc/Makefile.nt +++ b/ocamldoc/Makefile.nt @@ -24,7 +24,7 @@ OCAMLBIN = $(BINDIR) OCAMLPP=-pp "grep -v DEBUG" -# For installation +# For installation ############## MKDIR=mkdir CP=cp @@ -115,6 +115,7 @@ EXECMOFILES=$(CMOFILES)\ odoc_latex.cmo\ odoc_texi.cmo\ odoc_dot.cmo\ + odoc.cmo EXECMXFILES= $(EXECMOFILES:.cmo=.cmx) @@ -178,18 +179,18 @@ OCAMLCMXFILES=$(OCAMLCMOFILES:.cmo=.cmx) all: exe lib exe: $(OCAMLDOC) -lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) +lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) opt.opt: exeopt libopt exeopt: $(OCAMLDOC_OPT) -libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI) -debug: +libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI) +debug: make OCAMLPP="" -$(OCAMLDOC): $(EXECMOFILES) odoc.cmo - $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) odoc.cmo -$(OCAMLDOC_OPT): $(EXECMXFILES) odoc_opt.cmx - $(OCAMLOPT) -o $@ unix.cmxa str.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) odoc_opt.cmx +$(OCAMLDOC): $(EXECMOFILES) + $(OCAMLC) -o $@ -linkall unix.cma str.cma dynlink.cma $(LINKFLAGS) $(OCAMLCMOFILES) $(EXECMOFILES) +$(OCAMLDOC_OPT): $(EXECMXFILES) + $(OCAMLOPT) -o $@ unix.cmxa str.cmxa dynlink.cmxa $(LINKFLAGS) $(OCAMLCMXFILES) $(EXECMXFILES) $(OCAMLDOC_LIBCMA): $(LIBCMOFILES) $(OCAMLC) -a -o $@ $(LINKFLAGS) $(OCAMLCMOFILES) $(LIBCMOFILES) diff --git a/ocamldoc/odoc.ml b/ocamldoc/odoc.ml index fa9f0780f9..dbc7a7d007 100644 --- a/ocamldoc/odoc.ml +++ b/ocamldoc/odoc.ml @@ -25,17 +25,18 @@ let print_DEBUG s = print_string s ; print_newline () (* we check if we must load a module given on the command line *) let arg_list = Array.to_list Sys.argv -let (cmo_or_cma_opt, paths) = +let (cm_opt, paths) = let rec iter (f_opt, inc) = function [] | _ :: [] -> (f_opt, inc) | "-g" :: file :: q when ((Filename.check_suffix file "cmo") || - (Filename.check_suffix file "cma")) && + (Filename.check_suffix file "cma") || + (Filename.check_suffix file "cmxs")) && (f_opt = None) -> - iter (Some file, inc) q - | "-i" :: dir :: q -> - iter (f_opt, inc @ [dir]) q - | _ :: q -> + iter (Some file, inc) q + | "-i" :: dir :: q -> + iter (f_opt, inc @ [dir]) q + | _ :: q -> iter (f_opt, inc) q in iter (None, []) arg_list @@ -63,12 +64,11 @@ let get_real_filename name = ) let _ = - match cmo_or_cma_opt with + match cm_opt with None -> () | Some file -> - (* initializations for dynamic loading *) - Dynlink.init (); + let file = Dynlink.adapt_filename file in Dynlink.allow_unsafe_modules true; try let real_file = get_real_filename file in diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml index f535a018b6..4c9b583560 100644 --- a/ocamldoc/odoc_args.ml +++ b/ocamldoc/odoc_args.ml @@ -23,8 +23,6 @@ type source_file = let include_dirs = Clflags.include_dirs -let bytecode_mode = ref true - class type doc_generator = object method generate : Odoc_module.t_module list -> unit @@ -249,10 +247,8 @@ let options = ref [ "-dot", Arg.Unit (fun () -> set_doc_generator !default_dot_generator), M.generate_dot ; "-customdir", Arg.Unit (fun () -> Printf.printf "%s\n" Odoc_config.custom_generators_path; exit 0), M.display_custom_generators_dir ; - "-i", Arg.String (fun s -> if !bytecode_mode then () else (prerr_endline (M.option_not_in_native_code "-i"); exit 1)), - M.add_load_dir ; - "-g", Arg.String (fun s -> if !bytecode_mode then () else (prerr_endline (M.option_not_in_native_code "-g"); exit 1)), - M.load_file ^ + "-i", Arg.String (fun s -> ()), M.add_load_dir ; + "-g", Arg.String (fun s -> ()), M.load_file ^ "\n\n *** HTML options ***\n"; (* html only options *) diff --git a/ocamldoc/odoc_args.mli b/ocamldoc/odoc_args.mli index 428a2c823f..1267cc4100 100644 --- a/ocamldoc/odoc_args.mli +++ b/ocamldoc/odoc_args.mli @@ -21,10 +21,6 @@ type source_file = (** The include_dirs in the OCaml compiler. *) val include_dirs : string list ref -(** Indicate if we are in bytecode mode or not. - (For the [ocamldoc] command).*) -val bytecode_mode : bool ref - (** The class type of documentation generators. *) class type doc_generator = object method generate : Odoc_module.t_module list -> unit end diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml index dcfbfed2db..bc914c6e0f 100644 --- a/ocamldoc/odoc_man.ml +++ b/ocamldoc/odoc_man.ml @@ -201,10 +201,12 @@ class man = let len = String.length s in let b = Buffer.create len in for i = 0 to len - 1 do - match s.[i] with - '\\' -> Buffer.add_string b "\\(rs" - | '.' -> Buffer.add_string b "\\&." - | c -> Buffer.add_char b c + match s.[i] with + '\\' -> Buffer.add_string b "\\(rs" + | '.' -> Buffer.add_string b "\\&." + | '\'' -> Buffer.add_string b "\\&'" + | '-' -> Buffer.add_string b "\\-" + | c -> Buffer.add_char b c done; Buffer.contents b @@ -630,15 +632,15 @@ class man = (** Print groff string for a module comment.*) method man_of_module_comment b text = - bs b "\n.pp\n"; + bs b "\n.PP\n"; self#man_of_text b [Code ("=== "^(Odoc_misc.string_of_text text)^" ===")]; - bs b "\n.pp\n" + bs b "\n.PP\n" (** Print groff string for a class comment.*) method man_of_class_comment b text = - bs b "\n.pp\n"; + bs b "\n.PP\n"; self#man_of_text b [Code ("=== "^(Odoc_misc.string_of_text text)^" ===")]; - bs b "\n.pp\n" + bs b "\n.PP\n" (** Print groff string for an included module. *) method man_of_included_module b m_name im = diff --git a/ocamldoc/odoc_messages.ml b/ocamldoc/odoc_messages.ml index 4cf1e67f71..b20c8a9c16 100644 --- a/ocamldoc/odoc_messages.ml +++ b/ocamldoc/odoc_messages.ml @@ -24,7 +24,6 @@ let message_version = software^" "^config_version let usage = "Usage : "^(Sys.argv.(0))^" [options] <files>\n" let options_are = "Options are :" let option_version = "\tPrint version and exit" -let bytecode_only = "(bytecode version only)" let latex_only = "(LaTeX only)" let texi_only = "(TeXinfo only)" let latex_texi_only = "(LaTeX and TeXinfo only)" @@ -40,8 +39,8 @@ let option_impl ="<file>\tConsider <file> as a .ml file" let option_intf ="<file>\tConsider <file> as a .mli file" let display_custom_generators_dir = "\tDisplay custom generators standard directory and exit" let add_load_dir = "<dir>\tAdd the given directory to the search path for custom\n"^ - "\t\tgenerators "^bytecode_only -let load_file = "<file.cm[o|a]>\n\t\tLoad file defining a new documentation generator\n\t\t"^bytecode_only + "\t\tgenerators" +let load_file = "<file.cm[o|a|xs]>\n\t\tLoad file defining a new documentation generator" let nolabels = "\tIgnore non-optional labels in types" let werr = "\tTreat ocamldoc warnings as errors" let target_dir = "<dir>\tGenerate files in directory <dir>, rather than in current\n"^ diff --git a/ocamldoc/odoc_name.ml b/ocamldoc/odoc_name.ml index e187fb0b29..21bbee74d0 100644 --- a/ocamldoc/odoc_name.ml +++ b/ocamldoc/odoc_name.ml @@ -35,12 +35,13 @@ type t = string let parens_if_infix name = match name with - "" -> "" - | s -> - if List.mem s.[0] infix_chars then - "("^s^")" - else - s + | "" -> "" + | s when s.[0] = '*' || s.[String.length s - 1] = '*' -> "( " ^ s ^ " )" + | s when List.mem s.[0] infix_chars -> "(" ^ s ^ ")" + | "or" | "mod" | "land" | "lor" | "lxor" | "lsl" | "lsr" | "asr" -> + "(" ^ name ^ ")" + | _ -> name +;; let cut name = match name with diff --git a/ocamldoc/odoc_ocamlhtml.mll b/ocamldoc/odoc_ocamlhtml.mll index fd8aa6091e..2c1549670e 100644 --- a/ocamldoc/odoc_ocamlhtml.mll +++ b/ocamldoc/odoc_ocamlhtml.mll @@ -202,7 +202,7 @@ let reset_string_buffer () = Buffer.reset string_buffer let store_string_char = Buffer.add_char string_buffer let get_stored_string () = let s = Buffer.contents string_buffer in - String.escaped s + s (** To translate escape sequences *) @@ -219,6 +219,11 @@ let char_for_decimal_code lexbuf i = (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in Char.chr(c land 0xFF) +let char_for_hexa_code lexbuf i = + let c = 16 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + + (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) in + Char.chr(c land 0xFF) + (** To store the position of the beginning of a string and comment *) let string_start_pos = ref 0;; let comment_start_pos = ref [];; @@ -426,6 +431,7 @@ and comment = parse comment_start_pos := l; comment lexbuf; } +(* These filters are useless | "\"" { reset_string_buffer(); string_start_pos := Lexing.lexeme_start lexbuf; @@ -437,11 +443,6 @@ and comment = parse raise (Error (Unterminated_string_in_comment, st, st + 2)) end; comment lexbuf } - | "''" - { - store_comment_char '\''; - store_comment_char '\''; - comment lexbuf } | "'" [^ '\\' '\''] "'" { store_comment_char '\''; @@ -455,13 +456,20 @@ and comment = parse store_comment_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)) ; store_comment_char '\''; comment lexbuf } - | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" + | "\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] { - store_comment_char '\''; - store_comment_char '\\'; store_comment_char(char_for_decimal_code lexbuf 1); + comment lexbuf } + | "\\x" ['0'-'9' 'A'-'Z' 'a'-'z' ] ['0'-'9' 'A'-'Z' 'a'-'z'] + { + store_comment_char(char_for_hexa_code lexbuf 2); + string lexbuf } + | "''" + { + store_comment_char '\''; store_comment_char '\''; comment lexbuf } +*) | eof { let st = List.hd !comment_start_pos in raise (Error (Unterminated_comment, st, st + 2)); @@ -475,11 +483,16 @@ and string = parse { () } | '\\' ("\010" | "\013" | "\013\010") [' ' '\009'] * { string lexbuf } - | '\\' ['\\' '"' 'n' 't' 'b' 'r'] - { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); + | '\\' ['\\' '"' 'n' 't' 'b' 'r' ] + { Buffer.add_string string_buffer (Lexing.lexeme lexbuf) ; string lexbuf } | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] - { store_string_char(char_for_decimal_code lexbuf 1); + { + Buffer.add_string string_buffer (Lexing.lexeme lexbuf) ; + string lexbuf + } + | '\\' 'x' ['0'-'9' 'A'-'Z' 'a'-'z' ] ['0'-'9' 'A'-'Z' 'a'-'z'] + { Buffer.add_string string_buffer (Lexing.lexeme lexbuf) ; string lexbuf } | eof { raise (Error (Unterminated_string, diff --git a/ocamldoc/odoc_opt.ml b/ocamldoc/odoc_opt.ml deleted file mode 100644 index 8eb7e6fa38..0000000000 --- a/ocamldoc/odoc_opt.ml +++ /dev/null @@ -1,82 +0,0 @@ -(***********************************************************************) -(* OCamldoc *) -(* *) -(* Maxence Guesdon, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 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. *) -(* *) -(***********************************************************************) - -(* $Id$ *) - -(** Main module for native version.*) - -open Config -open Clflags -open Misc -open Format -open Typedtree - -let _ = Odoc_args.bytecode_mode := false - - -let html_generator = new Odoc_html.html -let default_latex_generator = new Odoc_latex.latex -let default_texi_generator = new Odoc_texi.texi -let default_man_generator = new Odoc_man.man -let default_dot_generator = new Odoc_dot.dot -let _ = Odoc_args.parse - (html_generator :> Odoc_args.doc_generator) - (default_latex_generator :> Odoc_args.doc_generator) - (default_texi_generator :> Odoc_args.doc_generator) - (default_man_generator :> Odoc_args.doc_generator) - (default_dot_generator :> Odoc_args.doc_generator) - -let loaded_modules = - List.flatten - (List.map - (fun f -> - Odoc_info.verbose (Odoc_messages.loading f); - try - let l = Odoc_analyse.load_modules f in - Odoc_info.verbose Odoc_messages.ok; - l - with Failure s -> - prerr_endline s ; - incr Odoc_global.errors ; - [] - ) - !Odoc_args.load - ) - -let modules = Odoc_analyse.analyse_files ~init: loaded_modules !Odoc_args.files - -let _ = - match !Odoc_args.dump with - None -> () - | Some f -> - try Odoc_analyse.dump_modules f modules - with Failure s -> - prerr_endline s ; - incr Odoc_global.errors - -let _ = - match !Odoc_args.doc_generator with - None -> - () - | Some gen -> - Odoc_info.verbose Odoc_messages.generating_doc; - gen#generate modules; - Odoc_info.verbose Odoc_messages.ok - -let _ = - if !Odoc_global.errors > 0 then - ( - prerr_endline (Odoc_messages.errors_occured !Odoc_global.errors) ; - exit 1 - ) - else - exit 0 - diff --git a/otherlibs/systhreads/Tests/Makefile b/otherlibs/systhreads/Tests/Makefile index 4d860b3e0c..16c908f203 100644 --- a/otherlibs/systhreads/Tests/Makefile +++ b/otherlibs/systhreads/Tests/Makefile @@ -16,7 +16,7 @@ PROGS=test1.byt test2.byt test3.byt test4.byt test5.byt test6.byt \ test7.byt test8.byt test9.byt testA.byt sieve.byt \ testio.byt testsocket.byt testsignal.byt testsignal2.byt \ - torture.byt + torture.byt testfork.byt include ../../../config/Makefile diff --git a/otherlibs/systhreads/posix.c b/otherlibs/systhreads/posix.c index 715741fc5b..da45be06cf 100644 --- a/otherlibs/systhreads/posix.c +++ b/otherlibs/systhreads/posix.c @@ -111,6 +111,9 @@ static pthread_mutex_t caml_runtime_mutex = PTHREAD_MUTEX_INITIALIZER; /* Condition signaled when caml_runtime_busy becomes 0 */ static pthread_cond_t caml_runtime_is_free = PTHREAD_COND_INITIALIZER; +/* Whether the ``tick'' thread is already running */ +static int caml_tick_thread_running = 0; + /* The key used for storing the thread descriptor in the specific data of the corresponding Posix thread. */ static pthread_key_t thread_descriptor_key; @@ -332,8 +335,6 @@ static void * caml_thread_tick(void * arg) static void caml_thread_reinitialize(void) { caml_thread_t thr, next; - pthread_t tick_pthread; - pthread_attr_t attr; struct channel * chan; /* Remove all other threads (now nonexistent) @@ -353,24 +354,21 @@ static void caml_thread_reinitialize(void) pthread_cond_init(&caml_runtime_is_free, NULL); caml_runtime_waiters = 0; /* no other thread is waiting for the RTS */ caml_runtime_busy = 1; /* normally useless */ + /* Tick thread is not currently running in child process, will be + re-created at next Thread.create */ + caml_tick_thread_running = 0; /* Reinitialize all IO mutexes */ for (chan = caml_all_opened_channels; chan != NULL; chan = chan->next) { if (chan->mutex != NULL) pthread_mutex_init(chan->mutex, NULL); } - /* Fork a new tick thread */ - pthread_attr_init(&attr); - pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); - pthread_create(&tick_pthread, &attr, caml_thread_tick, NULL); } /* Initialize the thread machinery */ value caml_thread_initialize(value unit) /* ML */ { - pthread_t tick_pthread; - pthread_attr_t attr; value mu = Val_unit; value descr; @@ -395,6 +393,7 @@ value caml_thread_initialize(value unit) /* ML */ curr_thread->descr = descr; curr_thread->next = curr_thread; curr_thread->prev = curr_thread; + curr_thread->backtrace_last_exn = Val_unit; #ifdef NATIVE_CODE curr_thread->exit_buf = &caml_termination_jmpbuf; #endif @@ -415,12 +414,6 @@ value caml_thread_initialize(value unit) /* ML */ caml_channel_mutex_lock = caml_io_mutex_lock; caml_channel_mutex_unlock = caml_io_mutex_unlock; caml_channel_mutex_unlock_exn = caml_io_mutex_unlock_exn; - /* Fork the tick thread */ - pthread_attr_init(&attr); - pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); - caml_pthread_check( - pthread_create(&tick_pthread, &attr, caml_thread_tick, NULL), - "Thread.init"); /* Set up fork() to reinitialize the thread machinery in the child (PR#4577) */ pthread_atfork(NULL, NULL, caml_thread_reinitialize); @@ -488,6 +481,7 @@ value caml_thread_new(value clos) /* ML */ { pthread_attr_t attr; caml_thread_t th; + pthread_t tick_pthread; value mu = Val_unit; value descr; int err; @@ -526,12 +520,12 @@ value caml_thread_new(value clos) /* ML */ th->prev = curr_thread; curr_thread->next->prev = th; curr_thread->next = th; - /* Fork the new thread */ + /* Create the new thread */ pthread_attr_init(&attr); pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); err = pthread_create(&th->pthread, &attr, caml_thread_start, (void *) th); if (err != 0) { - /* Fork failed, remove thread info block from list of threads */ + /* Creation failed, remove thread info block from list of threads */ th->next->prev = curr_thread; curr_thread->next = th->next; #ifndef NATIVE_CODE @@ -541,6 +535,16 @@ value caml_thread_new(value clos) /* ML */ caml_pthread_check(err, "Thread.create"); } End_roots(); + /* Create the tick thread if not already done. + Because of PR#4666, we start the tick thread late, only when we create + the first additional thread in the current process*/ + if (! caml_tick_thread_running) { + caml_tick_thread_running = 1; + pthread_attr_init(&attr); + pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); + err = pthread_create(&tick_pthread, &attr, caml_thread_tick, NULL); + caml_pthread_check(err, "Thread.create"); + } return descr; } diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile index af89857497..d2cda03319 100644 --- a/otherlibs/threads/Makefile +++ b/otherlibs/threads/Makefile @@ -94,10 +94,10 @@ marshal.cmi: $(LIB)/marshal.cmi ln -s $(LIB)/marshal.cmi marshal.cmi unix.mli: $(UNIXLIB)/unix.mli - ln -sf $(UNIXLIB)/unix.mli unix.mli + ln -s -f $(UNIXLIB)/unix.mli unix.mli unix.cmi: $(UNIXLIB)/unix.cmi - ln -sf $(UNIXLIB)/unix.cmi unix.cmi + ln -s -f $(UNIXLIB)/unix.cmi unix.cmi unix.cmo: unix.mli unix.cmi $(UNIXLIB)/unixLabels.cmo $(CAMLC) ${COMPFLAGS} -c unix.ml diff --git a/otherlibs/threads/Tests/Makefile b/otherlibs/threads/Tests/Makefile index ff013fe92c..3a3e0031fd 100644 --- a/otherlibs/threads/Tests/Makefile +++ b/otherlibs/threads/Tests/Makefile @@ -16,7 +16,7 @@ PROGS=test1.byt test2.byt test3.byt test4.byt test5.byt test6.byt \ test7.byt test8.byt test9.byt testA.byt sieve.byt \ testio.byt testsocket.byt testwait.byt testsignal.byt testsignal2.byt \ - testsieve.byt token1.byt token2.byt + testsieve.byt token1.byt token2.byt testfork.byt CAMLC=../../../boot/ocamlrun ../../../ocamlc -nojoin -I .. -I ../../../stdlib -I ../../unix diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli index 5ac6913206..e7ac4456f9 100644 --- a/otherlibs/unix/unix.mli +++ b/otherlibs/unix/unix.mli @@ -900,7 +900,8 @@ type socket_domain = PF_UNIX (** Unix domain *) | PF_INET (** Internet domain (IPv4) *) | PF_INET6 (** Internet domain (IPv6) *) -(** The type of socket domains. *) +(** The type of socket domains. Not all platforms support + IPv6 sockets (type [PF_INET6]). *) type socket_type = SOCK_STREAM (** Stream socket *) diff --git a/parsing/lexer.mll b/parsing/lexer.mll index 393c1d9a76..a38f1bfae4 100644 --- a/parsing/lexer.mll +++ b/parsing/lexer.mll @@ -146,9 +146,11 @@ let char_for_decimal_code lexbuf i = let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in - if (c < 0 || c > 255) && not (in_comment ()) - then raise (Error(Illegal_escape (Lexing.lexeme lexbuf), - Location.curr lexbuf)) + if (c < 0 || c > 255) then + if in_comment () + then 'x' + else raise (Error(Illegal_escape (Lexing.lexeme lexbuf), + Location.curr lexbuf)) else Char.chr c let char_for_hexadecimal_code lexbuf i = diff --git a/stdlib/.depend b/stdlib/.depend index a45db17dee..faa3382181 100644 --- a/stdlib/.depend +++ b/stdlib/.depend @@ -1,13 +1,46 @@ -camlinternalLazy.cmi: obj.cmi +arg.cmi: +array.cmi: +arrayLabels.cmi: +buffer.cmi: +callback.cmi: +camlinternalLazy.cmi: camlinternalMod.cmi: obj.cmi camlinternalOO.cmi: obj.cmi +char.cmi: +complex.cmi: +digest.cmi: +filename.cmi: format.cmi: buffer.cmi +gc.cmi: genlex.cmi: stream.cmi +hashtbl.cmi: +int32.cmi: +int64.cmi: +lazy.cmi: +lexing.cmi: +list.cmi: +listLabels.cmi: +map.cmi: +marshal.cmi: moreLabels.cmi: set.cmi map.cmi hashtbl.cmi +nativeint.cmi: +obj.cmi: oo.cmi: camlinternalOO.cmi parsing.cmi: obj.cmi lexing.cmi +pervasives.cmi: +printexc.cmi: printf.cmi: obj.cmi buffer.cmi +queue.cmi: random.cmi: nativeint.cmi int64.cmi int32.cmi +scanf.cmi: +set.cmi: +sort.cmi: +stack.cmi: +stdLabels.cmi: +stream.cmi: +string.cmi: +stringLabels.cmi: +sys.cmi: weak.cmi: hashtbl.cmi arg.cmo: sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi arg.cmi arg.cmx: sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx arg.cmi @@ -19,7 +52,8 @@ buffer.cmo: sys.cmi string.cmi buffer.cmi buffer.cmx: sys.cmx string.cmx buffer.cmi callback.cmo: obj.cmi callback.cmi callback.cmx: obj.cmx callback.cmi -camlinternalLazy.cmo: camlinternalLazy.cmi +camlinternalLazy.cmo: obj.cmi camlinternalLazy.cmi +camlinternalLazy.cmx: obj.cmx camlinternalLazy.cmi camlinternalMod.cmo: obj.cmi camlinternalOO.cmi array.cmi camlinternalMod.cmi camlinternalMod.cmx: obj.cmx camlinternalOO.cmx array.cmx camlinternalMod.cmi camlinternalOO.cmo: sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \ @@ -72,8 +106,8 @@ parsing.cmo: obj.cmi lexing.cmi array.cmi parsing.cmi parsing.cmx: obj.cmx lexing.cmx array.cmx parsing.cmi pervasives.cmo: pervasives.cmi pervasives.cmx: pervasives.cmi -printexc.cmo: printf.cmi obj.cmi printexc.cmi -printexc.cmx: printf.cmx obj.cmx printexc.cmi +printexc.cmo: printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi +printexc.cmx: printf.cmx obj.cmx buffer.cmx array.cmx printexc.cmi printf.cmo: string.cmi obj.cmi list.cmi char.cmi buffer.cmi array.cmi \ printf.cmi printf.cmx: string.cmx obj.cmx list.cmx char.cmx buffer.cmx array.cmx \ @@ -96,8 +130,10 @@ stack.cmo: list.cmi stack.cmi stack.cmx: list.cmx stack.cmi stdLabels.cmo: stringLabels.cmi listLabels.cmi arrayLabels.cmi stdLabels.cmi stdLabels.cmx: stringLabels.cmx listLabels.cmx arrayLabels.cmx stdLabels.cmi +std_exit.cmo: +std_exit.cmx: stream.cmo: string.cmi obj.cmi list.cmi lazy.cmi stream.cmi -stream.cmx: string.cmx obj.cmx list.cmx stream.cmi +stream.cmx: string.cmx obj.cmx list.cmx lazy.cmx stream.cmi string.cmo: pervasives.cmi list.cmi char.cmi string.cmi string.cmx: pervasives.cmx list.cmx char.cmx string.cmi stringLabels.cmo: string.cmi stringLabels.cmi diff --git a/stdlib/filename.ml b/stdlib/filename.ml index 7074be9e23..d3a68cf632 100644 --- a/stdlib/filename.ml +++ b/stdlib/filename.ml @@ -98,21 +98,24 @@ module Win32 = struct let b = Buffer.create (l + 20) in Buffer.add_char b '\"'; let rec loop i = - if i = l then () else + if i = l then Buffer.add_char b '\"' else match s.[i] with | '\"' -> loop_bs 0 i; | '\\' -> loop_bs 0 i; | c -> Buffer.add_char b c; loop (i+1); and loop_bs n i = - if i = l then add_bs (2*n) else - match s.[i] with - | '\"' -> add_bs (2*n+1); Buffer.add_char b '\"'; loop (i+1); - | '\\' -> loop_bs (n+1) (i+1); - | c -> add_bs n; loop i + if i = l then begin + Buffer.add_char b '\"'; + add_bs n; + end else begin + match s.[i] with + | '\"' -> add_bs (2*n+1); Buffer.add_char b '\"'; loop (i+1); + | '\\' -> loop_bs (n+1) (i+1); + | c -> add_bs n; loop i + end and add_bs n = for j = 1 to n do Buffer.add_char b '\\'; done in loop 0; - Buffer.add_char b '\"'; Buffer.contents b let has_drive s = let is_letter = function diff --git a/stdlib/format.ml b/stdlib/format.ml index 2083602b99..d40347faf0 100644 --- a/stdlib/format.ml +++ b/stdlib/format.ml @@ -1040,9 +1040,9 @@ let get_buffer_out b = s ;; -(* [ppf] is supposed to be a pretty-printer that outputs in buffer [b]: - to extract contents of [ppf] as a string we flush [ppf] and get the string - out of [b]. *) +(* [ppf] is supposed to be a pretty-printer that outputs to buffer [b]: + to extract the contents of [ppf] as a string we flush [ppf] and get the + string out of [b]. *) let string_out b ppf = pp_flush_queue ppf false; get_buffer_out b @@ -1311,7 +1311,10 @@ let kbprintf k b = mkprintf false (fun _ -> formatter_of_buffer b) k ;; -let bprintf b = kbprintf ignore b;; +let bprintf b = + let k ppf = pp_flush_queue ppf false in + kbprintf k b +;; let ksprintf k = let b = Buffer.create 512 in diff --git a/stdlib/gc.ml b/stdlib/gc.ml index 7299ff867c..db98de9783 100644 --- a/stdlib/gc.ml +++ b/stdlib/gc.ml @@ -38,6 +38,7 @@ type control = { mutable verbose : int; mutable max_overhead : int; mutable stack_limit : int; + mutable allocation_policy : int; };; external stat : unit -> stat = "caml_gc_stat";; diff --git a/stdlib/gc.mli b/stdlib/gc.mli index be476d21e9..809998c500 100644 --- a/stdlib/gc.mli +++ b/stdlib/gc.mli @@ -126,6 +126,14 @@ type control = (** The maximum size of the stack (in words). This is only relevant to the byte-code runtime, as the native code runtime uses the operating system's stack. Default: 256k. *) + + mutable allocation_policy : int; + (** The policy used for allocating in the heap. Possible + values are 0 and 1. 0 is the next-fit policy, which is + quite fast but can result in fragmentation. 1 is the + first-fit policy, which can be slower in some cases but + can be better for programs with fragmentation problems. + Default: 0. *) } (** The GC parameters are given as a [control] record. Note that these parameters can also be initialised by setting the diff --git a/stdlib/lexing.mli b/stdlib/lexing.mli index 1868825ce7..884bf38448 100644 --- a/stdlib/lexing.mli +++ b/stdlib/lexing.mli @@ -62,10 +62,11 @@ type lexbuf = The lexer buffer holds the current state of the scanner, plus a function to refill the buffer from the input. - Note that the lexing engine will only change the [pos_cnum] field + At each token, the lexing engine will copy [lex_curr_p] to + [lex_start_p], then change the [pos_cnum] field of [lex_curr_p] by updating it with the number of characters read - since the start of the [lexbuf]. The other fields are copied - without change by the lexing engine. In order to keep them + since the start of the [lexbuf]. The other fields are left + unchanged by the lexing engine. In order to keep them accurate, they must be initialised before the first use of the lexbuf, and updated by the relevant lexer actions (i.e. at each end of line -- see also [new_line]). diff --git a/stdlib/map.mli b/stdlib/map.mli index ca82413036..af1d4d37b7 100644 --- a/stdlib/map.mli +++ b/stdlib/map.mli @@ -73,9 +73,7 @@ module type S = (** [iter f m] applies [f] to all bindings in map [m]. [f] receives the key as first argument, and the associated value as second argument. The bindings are passed to [f] in increasing - order with respect to the ordering over the type of the keys. - Only current bindings are presented to [f]: - bindings hidden by more recent bindings are not passed to [f]. *) + order with respect to the ordering over the type of the keys. *) val map: ('a -> 'b) -> 'a t -> 'b t (** [map f m] returns a map with same domain as [m], where the diff --git a/stdlib/parsing.ml b/stdlib/parsing.ml index 2b4d93ddb8..44c7fb2715 100644 --- a/stdlib/parsing.ml +++ b/stdlib/parsing.ml @@ -180,9 +180,15 @@ let peek_val env n = Obj.magic env.v_stack.(env.asp - n) let symbol_start_pos () = - if env.rule_len > 0 - then env.symb_start_stack.(env.asp - env.rule_len + 1) - else env.symb_end_stack.(env.asp) + let rec loop i = + if i <= 0 then env.symb_end_stack.(env.asp) + else begin + let st = env.symb_start_stack.(env.asp - i + 1) in + let en = env.symb_end_stack.(env.asp - i + 1) in + if st <> en then st else loop (i - 1) + end + in + loop env.rule_len ;; let symbol_end_pos () = env.symb_end_stack.(env.asp);; let rhs_start_pos n = env.symb_start_stack.(env.asp - (env.rule_len - n));; diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli index 7ead634fbb..97ee3c94b8 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -24,6 +24,7 @@ name, without prefixing them by [Pervasives]. *) + (** {6 Exceptions} *) external raise : exn -> 'a = "%raise" @@ -42,7 +43,6 @@ exception Exit (** {6 Comparisons} *) - external ( = ) : 'a -> 'a -> bool = "%equal" (** [e1 = e2] tests for structural equality of [e1] and [e2]. Mutable structures (e.g. references and arrays) are equal @@ -100,8 +100,7 @@ val max : 'a -> 'a -> 'a external ( == ) : 'a -> 'a -> bool = "%eq" (** [e1 == e2] tests for physical equality of [e1] and [e2]. - On integers and characters, physical equality is identical to structural - equality. On mutable structures, [e1 == e2] is true if and only if + On mutable structures, [e1 == e2] is true if and only if physical modification of [e1] also affects [e2]. On non-mutable structures, the behavior of [(==)] is implementation-dependent; however, it is guaranteed that @@ -113,7 +112,6 @@ external ( != ) : 'a -> 'a -> bool = "%noteq" (** {6 Boolean operations} *) - external not : bool -> bool = "%boolnot" (** The boolean negation. *) @@ -186,10 +184,8 @@ val min_int : int (** The smallest representable integer. *) - (** {7 Bitwise operations} *) - external ( land ) : int -> int -> int = "%andint" (** Bitwise logical and. *) @@ -250,10 +246,10 @@ external ( /. ) : float -> float -> float = "%divfloat" (** Floating-point division. *) external ( ** ) : float -> float -> float = "caml_power_float" "pow" "float" -(** Exponentiation *) +(** Exponentiation. *) external sqrt : float -> float = "caml_sqrt_float" "sqrt" "float" -(** Square root *) +(** Square root. *) external exp : float -> float = "caml_exp_float" "exp" "float" (** Exponential. *) @@ -265,47 +261,57 @@ external log10 : float -> float = "caml_log10_float" "log10" "float" (** Base 10 logarithm. *) external cos : float -> float = "caml_cos_float" "cos" "float" -(** See {!Pervasives.atan2}. *) +(** [cos a] returns the cosine of angle [a] measured in radians. *) external sin : float -> float = "caml_sin_float" "sin" "float" -(** See {!Pervasives.atan2}. *) +(** [sin a] returns the sine of angle [a] measured in radians. *) external tan : float -> float = "caml_tan_float" "tan" "float" -(** See {!Pervasives.atan2}. *) +(** [tan a] returns the tangent of angle [a] measured in radians. *) external acos : float -> float = "caml_acos_float" "acos" "float" -(** See {!Pervasives.atan2}. *) +(** [acos f] returns the arc cosine of [f]. The return angle is measured + in radians. *) external asin : float -> float = "caml_asin_float" "asin" "float" -(** See {!Pervasives.atan2}. *) +(** [asin f] returns the arc sine of [f]. The return angle is measured + in radians. *) external atan : float -> float = "caml_atan_float" "atan" "float" -(** See {!Pervasives.atan2}. *) +(** [atan f] returns the arc tangent of [f]. The return angle is measured + in radians. *) external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float" -(** The usual trigonometric functions. *) +(** [atan2 y x] returns the principal value of the arc tangent of + [y / x], using the signs of both arguments to determine the quadrant of the + result. The return angle is measured in radians. *) external cosh : float -> float = "caml_cosh_float" "cosh" "float" -(** See {!Pervasives.tanh}. *) +(** [cosh a] returns the hyperbolic cosine of angle [a] measured + in radians. *) external sinh : float -> float = "caml_sinh_float" "sinh" "float" -(** See {!Pervasives.tanh}. *) +(** [sinh a] returns the hyperbolic sine of angle [a] measured + in radians. *) external tanh : float -> float = "caml_tanh_float" "tanh" "float" -(** The usual hyperbolic trigonometric functions. *) +(** [tanh f] returns the hyperbolic tangent of angle [a] measured + in radians. *) external ceil : float -> float = "caml_ceil_float" "ceil" "float" -(** See {!Pervasives.floor}. *) +(** Round the given float to an integer value. + [ceil f] returns the least integer value greater than or + equal to [f]. + See also {!Pervasives.floor}. *) external floor : float -> float = "caml_floor_float" "floor" "float" (** Round the given float to an integer value. [floor f] returns the greatest integer value less than or equal to [f]. - [ceil f] returns the least integer value greater than or - equal to [f]. *) + See also {!Pervasives.ceil}. *) external abs_float : float -> float = "%absfloat" -(** Return the absolute value of the argument. *) +(** [abs_float f] returns the absolute value of [f]. *) external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float" (** [mod_float a b] returns the remainder of [a] with respect to @@ -442,7 +448,6 @@ external float_of_string : string -> float = "caml_float_of_string" if the given string is not a valid representation of a float. *) - (** {6 Pair operations} *) external fst : 'a * 'b -> 'a = "%field0" @@ -544,8 +549,8 @@ val read_float : unit -> float The result is unspecified if the line read is not a valid representation of a floating-point number. *) -(** {7 General output functions} *) +(** {7 General output functions} *) type open_flag = Open_rdonly (** open for reading. *) @@ -771,6 +776,7 @@ val set_binary_mode_in : in_channel -> bool -> unit This function has no effect under operating systems that do not distinguish between text mode and binary mode. *) + (** {7 Operations on large files} *) module LargeFile : @@ -789,6 +795,7 @@ module LargeFile : regular integers (type [int]), these alternate functions allow operating on files whose sizes are greater than [max_int]. *) + (** {6 References} *) type 'a ref = { mutable contents : 'a } @@ -853,7 +860,6 @@ val ( ^^ ) : (** {6 Program termination} *) - val exit : int -> 'a (** Terminate the process, returning the given status code to the operating system: usually 0 to indicate no errors, diff --git a/stdlib/printf.ml b/stdlib/printf.ml index 92ce254769..a061af7359 100644 --- a/stdlib/printf.ml +++ b/stdlib/printf.ml @@ -142,7 +142,8 @@ let extract_format fmt start stop widths = | ('*', []) -> assert false (* should not happen *) | (c, _) -> - Buffer.add_char b c; fill_format (succ i) widths in + Buffer.add_char b c; + fill_format (succ i) widths in fill_format start (List.rev widths); Buffer.contents b ;; @@ -156,6 +157,15 @@ let extract_format_int conv fmt start stop widths = | _ -> sfmt ;; +let extract_format_float conv fmt start stop widths = + let sfmt = extract_format fmt start stop widths in + match conv with + | 'F' -> + sfmt.[String.length sfmt - 1] <- 'f'; + sfmt + | _ -> sfmt +;; + (* Returns the position of the next character following the meta format string, starting from position [i], inside a given format [fmt]. According to the character [conv], the meta format string is @@ -297,7 +307,7 @@ let ac_of_format fmt = let count_arguments_of_format fmt = let ac = ac_of_format fmt in - ac.ac_rglr + ac.ac_skip + ac.ac_rdrs + ac.ac_rglr ;; let list_iter_i f l = @@ -417,6 +427,31 @@ let get_index spec n = | Spec_index p -> p ;; +(* Format a float argument as a valid Caml lexem. *) +let format_float_lexem = + let valid_float_lexem sfmt s = + let l = String.length s in + if l = 0 then "nan" else + let add_dot sfmt s = + if s.[0] = ' ' || s.[0] = '+' || s.[0] = '0' + then String.sub s 1 (l - 1) ^ "." + else String.sub s 0 (l - 1) ^ "." in + + let rec loop i = + if i >= l then add_dot sfmt s else + match s.[i] with + | '.' -> s + | _ -> loop (i + 1) in + + loop 0 in + + (fun sfmt x -> + let s = format_float sfmt x in + match classify_float x with + | FP_normal | FP_subnormal | FP_zero -> valid_float_lexem sfmt s + | FP_nan | FP_infinite -> s) +;; + (* Decode a format string and act on it. [fmt] is the [printf] format string, and [pos] points to a [%] character in the format string. @@ -485,9 +520,11 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m = let (x : float) = get_arg spec n in let s = format_float (extract_format fmt pos i widths) x in cont_s (next_index spec n) s (succ i) - | 'F' -> + | 'F' as conv -> let (x : float) = get_arg spec n in - cont_s (next_index spec n) (string_of_float x) (succ i) + let s = + format_float_lexem (extract_format_float conv fmt pos i widths) x in + cont_s (next_index spec n) s (succ i) | 'B' | 'b' -> let (x : bool) = get_arg spec n in cont_s (next_index spec n) (string_of_bool x) (succ i) diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml index 5ab7aeba73..88a0f97f82 100644 --- a/stdlib/scanf.ml +++ b/stdlib/scanf.ml @@ -782,8 +782,7 @@ let scan_String max ib = | '\n', true | ' ', false -> skip_spaces false (Scanning.ignore_char ib max) - | '\\', false -> loop false max - | c, false -> loop false (Scanning.store_char ib c max) + | c, false -> loop false max | _, _ -> loop false (scan_backslash_char (max - 1) ib) in loop true max ;; @@ -1272,22 +1271,29 @@ let scanf fmt = bscanf Scanning.stdib fmt;; let bscanf_format ib fmt f = let fmt = Sformat.unsafe_to_string fmt in - let fmt1 = ignore (scan_String max_int ib); token_string ib in + let fmt1 = + ignore (scan_String max_int ib); + token_string ib in if not (compatible_format_type fmt1 fmt) then format_mismatch fmt1 fmt else f (string_to_format fmt1) ;; -let sscanf_format s fmt f = bscanf_format (Scanning.from_string s) fmt f;; +let sscanf_format s fmt = bscanf_format (Scanning.from_string s) fmt;; -let quote_string s = - let b = Buffer.create (String.length s + 2) in +let string_to_String s = + let l = String.length s in + let b = Buffer.create (l + 2) in Buffer.add_char b '\"'; - Buffer.add_string b s; + for i = 0 to l - 1 do + let c = s.[i] in + if c = '\"' then Buffer.add_char b '\\'; + Buffer.add_char b c; + done; Buffer.add_char b '\"'; Buffer.contents b ;; let format_from_string s fmt = - sscanf_format (quote_string s) fmt (fun x -> x) + sscanf_format (string_to_String s) fmt (fun x -> x) ;; diff --git a/stdlib/string.ml b/stdlib/string.ml index 2c140c206c..0cb67d289f 100644 --- a/stdlib/string.ml +++ b/stdlib/string.ml @@ -154,7 +154,7 @@ let index s c = index_rec s (length s) 0 c;; let index_from s i c = let l = length s in - if i < 0 || i >= l then invalid_arg "String.index_from" else + if i < 0 || i > l then invalid_arg "String.index_from" else index_rec s l i c;; let rec rindex_rec s i c = @@ -164,22 +164,18 @@ let rec rindex_rec s i c = let rindex s c = rindex_rec s (length s - 1) c;; let rindex_from s i c = - let l = length s in - if i < 0 || i >= l then invalid_arg "String.rindex_from" else + if i < -1 || i >= length s then invalid_arg "String.rindex_from" else rindex_rec s i c;; let contains_from s i c = let l = length s in - if i < 0 || i >= l then invalid_arg "String.contains_from" else + if i < 0 || i > l then invalid_arg "String.contains_from" else try ignore (index_rec s l i c); true with Not_found -> false;; -let contains s c = - let l = length s in - l <> 0 && contains_from s 0 c;; +let contains s c = contains_from s 0 c;; let rcontains_from s i c = - let l = length s in - if i < 0 || i >= l then invalid_arg "String.rcontains_from" else + if i < 0 || i >= length s then invalid_arg "String.rcontains_from" else try ignore (rindex_rec s i c); true with Not_found -> false;; type t = string diff --git a/stdlib/string.mli b/stdlib/string.mli index 203d42d124..21bfb7c0e1 100644 --- a/stdlib/string.mli +++ b/stdlib/string.mli @@ -13,37 +13,47 @@ (* $Id$ *) -(** String operations. *) +(** String operations. + Given a string [s] of length [l], we call character number in [s] + the index of a character in [s]. Indexes start at [0], and we will + call a character number valid in [s] if it falls within the range + [[0...l-1]]. A position is the point between two characters or at + the beginning or end of the string. We call a position valid + in [s] if it falls within the range [[0...l]]. Note that character + number [n] is between positions [n] and [n+1]. + + Two parameters [start] and [len] are said to designate a valid + substring of [s] if [len >= 0] and [start] and [start+len] are + valid positions in [s]. + *) external length : string -> int = "%string_length" (** Return the length (number of characters) of the given string. *) external get : string -> int -> char = "%string_safe_get" (** [String.get s n] returns character number [n] in string [s]. - The first character is character number 0. - The last character is character number [String.length s - 1]. You can also write [s.[n]] instead of [String.get s n]. - Raise [Invalid_argument "index out of bounds"] - if [n] is outside the range 0 to [(String.length s - 1)]. *) + Raise [Invalid_argument] if [n] not a valid character number in [s]. *) external set : string -> int -> char -> unit = "%string_safe_set" (** [String.set s n c] modifies string [s] in place, replacing the character number [n] by [c]. You can also write [s.[n] <- c] instead of [String.set s n c]. - Raise [Invalid_argument "index out of bounds"] - if [n] is outside the range 0 to [(String.length s - 1)]. *) + + Raise [Invalid_argument] if [n] is not a valid character number in [s]. *) external create : int -> string = "caml_create_string" (** [String.create n] returns a fresh string of length [n]. The string initially contains arbitrary characters. - Raise [Invalid_argument] if [n < 0] or [n > Sys.max_string_length]. -*) + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) val make : int -> char -> string (** [String.make n c] returns a fresh string of length [n], filled with the character [c]. + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}.*) val copy : string -> string @@ -51,16 +61,16 @@ val copy : string -> string val sub : string -> int -> int -> string (** [String.sub s start len] returns a fresh string of length [len], - containing the characters number [start] to [start + len - 1] - of string [s]. + containing the substring of [s] that starts at position [start] and + has length [len]. + Raise [Invalid_argument] if [start] and [len] do not - designate a valid substring of [s]; that is, if [start < 0], - or [len < 0], or [start + len > ]{!String.length}[ s]. *) + designate a valid substring of [s]. *) val fill : string -> int -> int -> char -> unit (** [String.fill s start len c] modifies string [s] in place, - replacing the characters number [start] to [start + len - 1] - by [c]. + replacing [len] characters by [c], starting at [start]. + Raise [Invalid_argument] if [start] and [len] do not designate a valid substring of [s]. *) @@ -69,7 +79,8 @@ val blit : string -> int -> string -> int -> int -> unit from string [src], starting at character number [srcoff], to string [dst], starting at character number [dstoff]. It works correctly even if [src] and [dst] are the same string, - and the source and destination chunks overlap. + and the source and destination intervals overlap. + Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid substring of [src], or if [dstoff] and [len] do not designate a valid substring of [dst]. *) @@ -91,25 +102,33 @@ val escaped : string -> string not a copy. *) val index : string -> char -> int -(** [String.index s c] returns the position of the leftmost +(** [String.index s c] returns the character number of the first occurrence of character [c] in string [s]. + Raise [Not_found] if [c] does not occur in [s]. *) val rindex : string -> char -> int -(** [String.rindex s c] returns the position of the rightmost +(** [String.rindex s c] returns the character number of the last occurrence of character [c] in string [s]. + Raise [Not_found] if [c] does not occur in [s]. *) val index_from : string -> int -> char -> int -(** Same as {!String.index}, but start - searching at the character position given as second argument. - [String.index s c] is equivalent to [String.index_from s 0 c].*) +(** [String.index_from s i c] returns the character number of the + first occurrence of character [c] in string [s] after position [i]. + [String.index s c] is equivalent to [String.index_from s 0 c]. + + Raise [Invalid_argument] if [i] is not a valid position in [s]. + Raise [Not_found] if [c] does not occur in [s] after position [i]. *) val rindex_from : string -> int -> char -> int -(** Same as {!String.rindex}, but start - searching at the character position given as second argument. +(** [String.rindex_from s i c] returns the character number of the + last occurrence of character [c] in string [s] before position [i+1]. [String.rindex s c] is equivalent to - [String.rindex_from s (String.length s - 1) c]. *) + [String.rindex_from s (String.length s - 1) c]. + + Raise [Invalid_argument] if [i+1] is not a valid position in [s]. + Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *) val contains : string -> char -> bool (** [String.contains s c] tests if character [c] @@ -117,15 +136,18 @@ val contains : string -> char -> bool val contains_from : string -> int -> char -> bool (** [String.contains_from s start c] tests if character [c] - appears in the substring of [s] starting from [start] to the end - of [s]. - Raise [Invalid_argument] if [start] is not a valid index of [s]. *) + appears in [s] after position [start]. + [String.contains s c] is equivalent to + [String.contains_from s 0 c]. + + Raise [Invalid_argument] if [start] is not a valid position in [s]. *) val rcontains_from : string -> int -> char -> bool (** [String.rcontains_from s stop c] tests if character [c] - appears in the substring of [s] starting from the beginning - of [s] to index [stop]. - Raise [Invalid_argument] if [stop] is not a valid index of [s]. *) + appears in [s] before position [stop+1]. + + Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid + position in [s]. *) val uppercase : string -> string (** Return a copy of the argument, with all lowercase letters diff --git a/stdlib/weak.mli b/stdlib/weak.mli index 70fcfa3f54..a4660d1bb6 100644 --- a/stdlib/weak.mli +++ b/stdlib/weak.mli @@ -20,8 +20,11 @@ type 'a t (** The type of arrays of weak pointers (weak arrays). A weak - pointer is a value that the garbage collector may erase at - any time. + pointer is a value that the garbage collector may erase whenever + the value is not used any more (through normal pointers) by the + program. Note that finalisation functions are run after the + weak pointers are erased. + A weak pointer is said to be full if it points to a value, empty if the value was erased by the GC. diff --git a/tools/.depend b/tools/.depend index 3ce73f53dc..b51459b67e 100644 --- a/tools/.depend +++ b/tools/.depend @@ -1,8 +1,11 @@ depend.cmi: ../parsing/parsetree.cmi +profiling.cmi: addlabels.cmo: ../parsing/parsetree.cmi ../parsing/parse.cmi \ ../parsing/longident.cmi ../parsing/location.cmi ../parsing/asttypes.cmi addlabels.cmx: ../parsing/parsetree.cmi ../parsing/parse.cmx \ ../parsing/longident.cmx ../parsing/location.cmx ../parsing/asttypes.cmi +cvt_emit.cmo: +cvt_emit.cmx: depend.cmo: ../parsing/parsetree.cmi ../parsing/longident.cmi \ ../parsing/location.cmi depend.cmi depend.cmx: ../parsing/parsetree.cmi ../parsing/longident.cmx \ @@ -23,8 +26,12 @@ dumpobj.cmx: ../utils/tbl.cmx opnames.cmx ../bytecomp/opcodes.cmx \ ../parsing/asttypes.cmi lexer301.cmo: ../utils/warnings.cmi ../utils/misc.cmi ../parsing/location.cmi lexer301.cmx: ../utils/warnings.cmx ../utils/misc.cmx ../parsing/location.cmx +myocamlbuild_config.cmo: +myocamlbuild_config.cmx: objinfo.cmo: ../utils/config.cmi ../bytecomp/cmo_format.cmi objinfo.cmx: ../utils/config.cmx ../bytecomp/cmo_format.cmi +ocaml299to3.cmo: +ocaml299to3.cmx: ocamlcp.cmo: ../driver/main_args.cmi ocamlcp.cmx: ../driver/main_args.cmx ocamldep.cmo: ../parsing/syntaxerr.cmi ../parsing/parsetree.cmi \ @@ -47,6 +54,8 @@ ocamlprof.cmx: ../utils/warnings.cmx ../parsing/syntaxerr.cmx \ ../parsing/parsetree.cmi ../parsing/parse.cmx ../utils/misc.cmx \ ../parsing/location.cmx ../parsing/lexer.cmx ../utils/config.cmx \ ../utils/clflags.cmx +opnames.cmo: +opnames.cmx: primreq.cmo: ../utils/config.cmi ../bytecomp/cmo_format.cmi primreq.cmx: ../utils/config.cmx ../bytecomp/cmo_format.cmi profiling.cmo: profiling.cmi diff --git a/tools/Makefile.shared b/tools/Makefile.shared index 3b68be2bf6..5c0fd1ed0c 100644 --- a/tools/Makefile.shared +++ b/tools/Makefile.shared @@ -23,8 +23,7 @@ INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \ COMPFLAGS= -warn-error A $(INCLUDES) LINKFLAGS=$(INCLUDES) -all: ocamldep ocamlprof ocamlcp ocamlmktop ocamlmklib scrapelabels addlabels \ - dumpobj +all: ocamldep ocamlprof ocamlcp ocamlmktop ocamlmklib dumpobj .PHONY: all opt.opt: ocamldep.opt @@ -51,9 +50,9 @@ clean:: rm -f ocamldep.opt install:: - cp ocamldep $(BINDIR)/ocamldep$(EXE) + cp ocamldep $(BINDIR)/jocamldep$(EXE) if test -f ocamldep.opt; \ - then cp ocamldep.opt $(BINDIR)/ocamldep.opt$(EXE); else :; fi + then cp ocamldep.opt $(BINDIR)/jocamldep.opt$(EXE); else :; fi # The profiler @@ -69,15 +68,15 @@ ocamlcp: ocamlcp.cmo $(CAMLC) $(LINKFLAGS) -o ocamlcp main_args.cmo ocamlcp.cmo install:: - cp ocamlprof $(BINDIR)/ocamlprof$(EXE) - cp ocamlcp $(BINDIR)/ocamlcp$(EXE) + cp ocamlprof $(BINDIR)/jocamlprof$(EXE) + cp ocamlcp $(BINDIR)/jocamlcp$(EXE) cp profiling.cmi profiling.cmo $(LIBDIR) clean:: rm -f ocamlprof ocamlcp install:: - cp ocamlmktop $(BINDIR)/ocamlmktop$(EXE) + cp ocamlmktop $(BINDIR)/jocamlmktop$(EXE) clean:: rm -f ocamlmktop @@ -97,7 +96,7 @@ myocamlbuild_config.ml: ../config/Makefile ../build/mkmyocamlbuild_config.sh cp ../myocamlbuild_config.ml . install:: - cp ocamlmklib $(BINDIR)/ocamlmklib$(EXE) + cp ocamlmklib $(BINDIR)/jocamlmklib$(EXE) clean:: rm -f ocamlmklib @@ -121,7 +120,7 @@ clean:: # To make custom toplevels (see Makefile/Makefile.nt) install:: - cp ocamlmktop $(BINDIR)/ocamlmktop$(EXE) + cp ocamlmktop $(BINDIR)/jocamlmktop$(EXE) clean:: rm -f ocamlmktop @@ -154,8 +153,8 @@ scrapelabels: $(SCRAPELABELS) lexer301.ml: lexer301.mll $(CAMLLEX) lexer301.mll -install:: - cp scrapelabels $(LIBDIR) +#install:: +# cp scrapelabels $(LIBDIR) clean:: rm -f scrapelabels lexer301.ml @@ -170,8 +169,8 @@ addlabels: addlabels.ml $(CAMLC) $(LINKFLAGS) -w sl -o addlabels \ $(ADDLABELS_IMPORTS) addlabels.ml -install:: - cp addlabels $(LIBDIR) +#install:: +# cp addlabels $(LIBDIR) clean:: rm -f addlabels diff --git a/tools/make-package-macosx b/tools/make-package-macosx index 5a1b76eef1..7e671e2910 100755 --- a/tools/make-package-macosx +++ b/tools/make-package-macosx @@ -87,7 +87,8 @@ mkdir -p resources cat >resources/ReadMe.txt <<EOF This package installs Objective Caml version ${VERSION}. You need Mac OS X 10.5.x (Leopard), with the -XCode tools (v3.x) installed (and optionally X11). +XCode tools installed (v3.1.1 or later), and +optionally X11. Files will be installed in the following directories: diff --git a/toplevel/opttopdirs.ml b/toplevel/opttopdirs.ml index 5c63052262..8841dc2515 100644 --- a/toplevel/opttopdirs.ml +++ b/toplevel/opttopdirs.ml @@ -182,6 +182,9 @@ let _ = Hashtbl.add directive_table "principal" (Directive_bool(fun b -> Clflags.principal := b)); + Hashtbl.add directive_table "rectypes" + (Directive_none(fun () -> Clflags.recursive_types := true)); + Hashtbl.add directive_table "warnings" (Directive_string (parse_warnings std_out false)); diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index eb5f327c3f..0ea0c76f3c 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -294,6 +294,9 @@ let _ = Hashtbl.add directive_table "principal" (Directive_bool(fun b -> Clflags.principal := b)); + Hashtbl.add directive_table "rectypes" + (Directive_none(fun () -> Clflags.recursive_types := true)); + Hashtbl.add directive_table "warnings" (Directive_string (parse_warnings std_out false)); diff --git a/typing/ctype.ml b/typing/ctype.ml index 69061e5f1c..ceb3fe04b9 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -385,23 +385,32 @@ let closed_schema ty = exception Non_closed of type_expr * bool let free_variables = ref [] +let really_closed = ref None let rec free_vars_rec real ty = let ty = repr ty in if ty.level >= lowest_level then begin ty.level <- pivot_level - ty.level; - begin match ty.desc with - Tvar -> + begin match ty.desc, !really_closed with + Tvar, _ -> free_variables := (ty, real) :: !free_variables + | Tconstr (path, tl, _), Some env -> + begin try + let (_, body) = Env.find_type_expansion path env in + if (repr body).level <> generic_level then + free_variables := (ty, real) :: !free_variables + with Not_found -> () + end; + List.iter (free_vars_rec true) tl (* Do not count "virtual" free variables | Tobject(ty, {contents = Some (_, p)}) -> free_vars_rec false ty; List.iter (free_vars_rec true) p *) - | Tobject (ty, _) -> + | Tobject (ty, _), _ -> free_vars_rec false ty - | Tfield (_, _, ty1, ty2) -> + | Tfield (_, _, ty1, ty2), _ -> free_vars_rec true ty1; free_vars_rec false ty2 - | Tvariant row -> + | Tvariant row, _ -> let row = row_repr row in iter_row (free_vars_rec true) row; if not (static_row row) then free_vars_rec false row.row_more @@ -410,15 +419,17 @@ let rec free_vars_rec real ty = end; end -let free_vars ty = +let free_vars ?env ty = free_variables := []; + really_closed := env; free_vars_rec true ty; let res = !free_variables in free_variables := []; + really_closed := None; res -let free_variables ty = - let tl = List.map fst (free_vars ty) in +let free_variables ?env ty = + let tl = List.map fst (free_vars ?env ty) in unmark_type ty; tl @@ -1484,6 +1495,9 @@ let mkvariant fields closed = {row_fields = fields; row_closed = closed; row_more = newvar(); row_bound = (); row_fixed = false; row_name = None }) +(* force unification in Reither when one side has as non-conjunctive type *) +let rigid_variants = ref false + (**** Unification ****) (* Return whether [t0] occurs in [ty]. Objects are also traversed. *) @@ -1832,7 +1846,8 @@ and unify_row_field env fixed1 fixed2 l f1 f2 = | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) -> if e1 == e2 then () else let redo = - (m1 || m2) && + (m1 || m2 || + !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) && begin match tl1 @ tl2 with [] -> false | t1 :: tl -> if c1 || c2 then raise (Unify []); @@ -2070,7 +2085,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 = with Not_found -> TypePairs.add type_pairs (t1', t2') (); match (t1'.desc, t2'.desc) with - (Tvar, _) when may_instantiate inst_nongen t1 -> + (Tvar, _) when may_instantiate inst_nongen t1' -> moregen_occur env t1'.level t2; link_type t1' t2 | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when l1 = l2 @@ -2285,6 +2300,12 @@ let matches env ty ty' = (* Equivalence between parameterized types *) (*********************************************) +let expand_head_rigid env ty = + let old = !rigid_variants in + rigid_variants := true; + let ty' = expand_head_unif env ty in + rigid_variants := old; ty' + let normalize_subst subst = if List.exists (function {desc=Tlink _}, _ | _, {desc=Tlink _} -> true | _ -> false) @@ -2309,8 +2330,8 @@ let rec eqtype rename type_pairs subst env t1 t2 = | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> () | _ -> - let t1' = expand_head_unif env t1 in - let t2' = expand_head_unif env t2 in + let t1' = expand_head_rigid env t1 in + let t2' = expand_head_rigid env t2 in (* Expansion may have changed the representative of the types... *) let t1' = repr t1' and t2' = repr t2' in if t1' == t2' then () else @@ -2364,10 +2385,9 @@ and eqtype_list rename type_pairs subst env tl1 tl2 = and eqtype_fields rename type_pairs subst env ty1 ty2 = let (fields2, rest2) = flatten_fields ty2 in (* Try expansion, needed when called from Includecore.type_manifest *) - try match try_expand_head env rest2 with + match expand_head_rigid env rest2 with {desc=Tobject(ty2,_)} -> eqtype_fields rename type_pairs subst env ty1 ty2 - | _ -> raise Cannot_expand - with Cannot_expand -> + | _ -> let (fields1, rest1) = flatten_fields ty1 in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in eqtype rename type_pairs subst env rest1 rest2; @@ -2390,10 +2410,9 @@ and eqtype_kind k1 k2 = and eqtype_row rename type_pairs subst env row1 row2 = (* Try expansion, needed when called from Includecore.type_manifest *) - try match try_expand_head env (row_more row2) with + match expand_head_rigid env (row_more row2) with {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2 - | _ -> raise Cannot_expand - with Cannot_expand -> + | _ -> let row1 = row_repr row1 and row2 = row_repr row2 in let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in if row1.row_closed <> row2.row_closed @@ -2834,6 +2853,10 @@ let rec build_subtype env visited loops posi level t = ty1, tl1 | _ -> raise Not_found in + (* Fix PR4505: do not set ty to Tvar when it appears in tl1, + as this occurence might break the occur check. + XXX not clear whether this correct anyway... *) + if List.exists (deep_occur ty) tl1 then raise Not_found; ty.desc <- Tvar; let t'' = newvar () in let loops = (ty, t'') :: loops in @@ -3205,16 +3228,17 @@ let cyclic_abbrev env id ty = in check_cycle [] ty (* Normalize a type before printing, saving... *) -let rec normalize_type_rec env ty = +(* Cannot use mark_type because deep_occur uses it too *) +let rec normalize_type_rec env visited ty = let ty = repr ty in - if ty.level >= lowest_level then begin - mark_type_node ty; + if not (TypeSet.mem ty !visited) then begin + visited := TypeSet.add ty !visited; begin match ty.desc with | Tvariant row -> let row = row_repr row in let fields = List.map - (fun (l,f) -> - let f = row_field_repr f in l, + (fun (l,f0) -> + let f = row_field_repr f0 in l, match f with Reither(b, ty::(_::_ as tyl), m, e) -> let tyl' = List.fold_left @@ -3223,10 +3247,8 @@ let rec normalize_type_rec env ty = then tyl else ty::tyl) [ty] tyl in - if List.length tyl' <= List.length tyl then - let f = Reither(b, List.rev tyl', m, ref None) in - set_row_field e f; - f + if f != f0 || List.length tyl' < List.length tyl then + Reither(b, List.rev tyl', m, e) else f | _ -> f) row.row_fields in @@ -3239,11 +3261,15 @@ let rec normalize_type_rec env ty = begin match !nm with | None -> () | Some (n, v :: l) -> - let v' = repr v in + if deep_occur ty (newgenty (Ttuple l)) then + (* The abbreviation may be hiding something, so remove it *) + set_name nm None + else let v' = repr v in begin match v'.desc with | Tvar|Tunivar -> if v' != v then set_name nm (Some (n, v' :: l)) - | Tnil -> log_type ty; ty.desc <- Tconstr (n, l, ref Mnil) + | Tnil -> + log_type ty; ty.desc <- Tconstr (n, l, ref Mnil) | _ -> set_name nm None end | _ -> @@ -3256,12 +3282,11 @@ let rec normalize_type_rec env ty = log_type ty; fi.desc <- fi'.desc | _ -> () end; - iter_type_expr (normalize_type_rec env) ty + iter_type_expr (normalize_type_rec env visited) ty end let normalize_type env ty = - normalize_type_rec env ty; - unmark_type ty + normalize_type_rec env (ref TypeSet.empty) ty (*************************) @@ -3302,8 +3327,8 @@ let rec nondep_type_rec env id ty = (recursive type), so one cannot just take its description. *) - with Cannot_expand -> - raise Not_found + with Cannot_expand | Unify _ -> (* expand_abbrev failed *) + raise Not_found (* cf. PR4775 for Unify *) end else Tconstr(p, List.map (nondep_type_rec env id) tl, ref Mnil) diff --git a/typing/ctype.mli b/typing/ctype.mli index 29349573e6..0ecce970f6 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -133,6 +133,7 @@ val apply: val expand_head_once: Env.t -> type_expr -> type_expr val expand_head: Env.t -> type_expr -> type_expr +val try_expand_once_opt: Env.t -> type_expr -> type_expr val expand_head_opt: Env.t -> type_expr -> type_expr (** The compiler's own version of [expand_head] necessary for type-based optimisations. *) @@ -229,7 +230,8 @@ val closed_schema: type_expr -> bool (* Check whether the given type scheme contains no non-generic type variables *) -val free_variables: type_expr -> type_expr list +val free_variables: ?env:Env.t -> type_expr -> type_expr list + (* If env present, then check for incomplete definitions too *) val closed_type_decl: type_declaration -> type_expr option type closed_class_failure = CC_Method of type_expr * bool * string * type_expr diff --git a/typing/env.ml b/typing/env.ml index e349207186..a953de2f13 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -96,19 +96,29 @@ let empty = { continuations = Ident.empty; summary = Env_empty } -let diff_keys tbl1 tbl2 = +let diff_keys is_local tbl1 tbl2 = let keys2 = Ident.keys tbl2 in List.filter (fun id -> - match Ident.find_same id tbl2 with Pident _, _ -> - (try ignore (Ident.find_same id tbl1); false with Not_found -> true) - | _ -> false) + is_local (Ident.find_same id tbl2) && + try ignore (Ident.find_same id tbl1); false with Not_found -> true) keys2 +let is_ident = function + Pident _ -> true + | Pdot _ | Papply _ -> false + +let is_local (p, _) = is_ident p + +let is_local_exn = function + {cstr_tag = Cstr_exception p} -> is_ident p + | _ -> false + let diff env1 env2 = - diff_keys env1.values env2.values @ - diff_keys env1.modules env2.modules @ - diff_keys env1.classes env2.classes + diff_keys is_local env1.values env2.values @ + diff_keys is_local_exn env1.constrs env2.constrs @ + diff_keys is_local env1.modules env2.modules @ + diff_keys is_local env1.classes env2.classes (* Forward declarations *) diff --git a/typing/includeclass.ml b/typing/includeclass.ml index 49e0ce9d2e..007182a3d6 100644 --- a/typing/includeclass.ml +++ b/typing/includeclass.ml @@ -47,7 +47,7 @@ let include_err ppf = fprintf ppf "@[%a@]" (Printtyp.unification_error false trace (function ppf -> - fprintf ppf "One type parameter has type")) + fprintf ppf "A type parameter has type")) (function ppf -> fprintf ppf "but is expected to have type") | CM_Class_type_mismatch (cty1, cty2) -> @@ -58,7 +58,7 @@ let include_err ppf = fprintf ppf "@[%a@]" (Printtyp.unification_error false trace (function ppf -> - fprintf ppf "One parameter has type")) + fprintf ppf "A parameter has type")) (function ppf -> fprintf ppf "but is expected to have type") | CM_Val_type_mismatch (lab, trace) -> @@ -92,7 +92,7 @@ let include_err ppf = | CM_Public_method lab -> fprintf ppf "@[The public method %s cannot become private" lab | CM_Virtual_method lab -> - fprintf ppf "@[The virtual method %s cannot become concrete" lab + fprintf ppf "@[The virtual method %s cannot become concrete" lab | CM_Private_method lab -> fprintf ppf "The private method %s cannot become public" lab diff --git a/typing/includecore.ml b/typing/includecore.ml index de0faaebb0..1550488721 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -54,7 +54,7 @@ let is_absrow env ty = end | _ -> false -let type_manifest env ty1 params1 ty2 params2 = +let type_manifest env ty1 params1 ty2 params2 priv2 = let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in match ty1'.desc, ty2'.desc with Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) -> @@ -97,7 +97,13 @@ let type_manifest env ty1 params1 ty2 params2 = List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) in Ctype.equal env true (params1 @ tl1) (params2 @ tl2) | _ -> - Ctype.equal env true (ty1 :: params1) (ty2 :: params2) + let rec check_super ty1 = + Ctype.equal env true (ty1 :: params1) (ty2 :: params2) || + priv2 = Private && + try check_super + (Ctype.try_expand_once_opt env (Ctype.expand_head env ty1)) + with Ctype.Cannot_expand -> false + in check_super ty1 (* Inclusion between type declarations *) @@ -131,6 +137,7 @@ let type_declarations env id decl1 decl2 = Ctype.equal env true decl1.type_params decl2.type_params | (Some ty1, Some ty2) -> type_manifest env ty1 decl1.type_params ty2 decl2.type_params + decl2.type_private | (None, Some ty2) -> let ty1 = Btype.newgenty (Tconstr(Pident id, decl2.type_params, ref Mnil)) diff --git a/typing/mtype.ml b/typing/mtype.ml index 95c995dcde..b3a7c58fc6 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -51,11 +51,13 @@ and strengthen_sig env sg p = match decl.type_manifest with Some ty when decl.type_private = Public -> decl | _ -> - { decl with - type_private = Public; - type_manifest = - Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id, nopos), - decl.type_params, ref Mnil))) } + let manif = + Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id, nopos), + decl.type_params, ref Mnil))) in + if decl.type_kind = Type_abstract then + { decl with type_private = Public; type_manifest = manif } + else + { decl with type_manifest = manif } in Tsig_type(id, newdecl, rs) :: strengthen_sig env rem p | (Tsig_exception(id, d) as sigelt) :: rem -> diff --git a/typing/oprint.ml b/typing/oprint.ml index 0d5823de4c..76fdd376cf 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -55,11 +55,13 @@ let float_repres f = | FP_infinite -> if f < 0.0 then "neg_infinity" else "infinity" | _ -> - let s1 = Printf.sprintf "%.12g" f in - if f = float_of_string s1 then valid_float_lexeme s1 else - let s2 = Printf.sprintf "%.15g" f in - if f = float_of_string s2 then valid_float_lexeme s2 else - Printf.sprintf "%.18g" f + let float_val = + let s1 = Printf.sprintf "%.12g" f in + if f = float_of_string s1 then s1 else + let s2 = Printf.sprintf "%.15g" f in + if f = float_of_string s2 then s2 else + Printf.sprintf "%.18g" f + in valid_float_lexeme float_val let parenthesize_if_neg ppf fmt v isneg = if isneg then pp_print_char ppf '('; @@ -342,7 +344,7 @@ and print_out_sig_item ppf = | Osig_modtype (name, mty) -> fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty | Osig_module (name, mty, rs) -> - fprintf ppf "@[<2>%s %s :@ %a@]" + fprintf ppf "@[<2>%s %s :@ %a@]" (match rs with Orec_not -> "module" | Orec_first -> "module rec" | Orec_next -> "and") diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 1597e810b8..31e1b57e41 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -113,13 +113,18 @@ and compats ps qs = match ps,qs with exception Empty (* Empty pattern *) +(* May need a clean copy, cf. PR#4745 *) +let clean_copy ty = + if ty.level = Btype.generic_level then ty + else Subst.type_expr Subst.identity ty + let get_type_path ty tenv = - let ty = Ctype.repr (Ctype.expand_head tenv ty) in + let ty = Ctype.repr (Ctype.expand_head tenv (clean_copy ty)) in match ty.desc with | Tconstr (path,_,_) -> path | _ -> fatal_error "Parmatch.get_type_path" -let get_type_descr ty tenv = +let rec get_type_descr ty tenv = match (Ctype.repr ty).desc with | Tconstr (path,_,_) -> Env.find_type path tenv | _ -> fatal_error "Parmatch.get_type_descr" @@ -129,7 +134,7 @@ let rec get_constr tag ty tenv = | {type_kind=Type_variant constr_list} -> Datarepr.find_constr_by_tag tag constr_list | {type_manifest = Some _} -> - get_constr tag (Ctype.expand_head_once tenv ty) tenv + get_constr tag (Ctype.expand_head_once tenv (clean_copy ty)) tenv | _ -> fatal_error "Parmatch.get_constr" let find_label lbl lbls = @@ -142,7 +147,7 @@ let rec get_record_labels ty tenv = match get_type_descr ty tenv with | {type_kind = Type_record(lbls, rep)} -> lbls | {type_manifest = Some _} -> - get_record_labels (Ctype.expand_head_once tenv ty) tenv + get_record_labels (Ctype.expand_head_once tenv (clean_copy ty)) tenv | _ -> fatal_error "Parmatch.get_record_labels" diff --git a/typing/subst.ml b/typing/subst.ml index 6b1282697a..833b3634aa 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -294,3 +294,12 @@ and signature_component s comp newid = and modtype_declaration s = function Tmodtype_abstract -> Tmodtype_abstract | Tmodtype_manifest mty -> Tmodtype_manifest(modtype s mty) + +(* Composition of substitutions: + apply (compose s1 s2) x = apply s2 (apply s1 x) *) + +let compose s1 s2 = + { types = Tbl.map (fun id p -> type_path s2 p) s1.types; + modules = Tbl.map (fun id p -> module_path s2 p) s1.modules; + modtypes = Tbl.map (fun id mty -> modtype s2 mty) s1.modtypes; + for_saving = false } diff --git a/typing/subst.mli b/typing/subst.mli index d313853251..02ecf2054b 100644 --- a/typing/subst.mli +++ b/typing/subst.mli @@ -52,3 +52,7 @@ val cltype_declaration: t -> cltype_declaration -> cltype_declaration val modtype: t -> module_type -> module_type val signature: t -> signature -> signature val modtype_declaration: t -> modtype_declaration -> modtype_declaration + +(* Composition of substitutions: + apply (compose s1 s2) x = apply s2 (apply s1 x) *) +val compose: t -> t -> t diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 03b3b62171..7f6c1de241 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -1574,12 +1574,12 @@ let report_error ppf = function fprintf ppf "@[The type of self cannot be coerced to@ \ the type of the current class:@ %a.@.\ - Some occurences are contravariant@]" + Some occurrences are contravariant@]" Printtyp.type_scheme ty | Non_collapsable_conjunction (id, clty, trace) -> fprintf ppf "@[The type of this class,@ %a,@ \ - contains non-collapsable conjunctive types in constraints@]" + contains non-collapsible conjunctive types in constraints@]" (Printtyp.class_declaration id) clty; Printtyp.report_unification_error ppf trace (fun ppf -> fprintf ppf "Type") @@ -1589,11 +1589,11 @@ let report_error ppf = function (function ppf -> fprintf ppf "This object is expected to have type") (function ppf -> - fprintf ppf "but has actually type") + fprintf ppf "but actually has type") | Mutability_mismatch (lab, mut) -> let mut1, mut2 = if mut = Immutable then "mutable", "immutable" else "immutable", "mutable" in fprintf ppf - "@[The instance variable is %s,@ it cannot be redefined as %s@]" + "@[The instance variable is %s;@ it cannot be redefined as %s@]" mut1 mut2 diff --git a/typing/typecore.ml b/typing/typecore.ml index 7d41c3277b..694c68519e 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -1605,10 +1605,11 @@ and do_type_exp ctx env sexp = begin match arg.exp_desc, !self_coercion, (repr ty').desc with Texp_ident(_, {val_kind=Val_self _}), (path,r) :: _, Tconstr(path',_,_) when Path.same path path' -> + (* prerr_endline "self coercion"; *) r := sexp.pexp_loc :: !r; force () - | _ when free_variables arg.exp_type = [] - && free_variables ty' = [] -> + | _ when free_variables ~env arg.exp_type = [] + && free_variables ~env ty' = [] -> if not gen && (* first try a single coercion *) let snap = snapshot () in let ty, b = enlarge_type env ty' in @@ -1624,6 +1625,7 @@ and do_type_exp ctx env sexp = Location.prerr_warning sexp.pexp_loc (Warnings.Not_principal "this ground coercion"); with Subtype (tr1, tr2) -> + (* prerr_endline "coercion failed"; *) raise(Error(sexp.pexp_loc, Not_subtype(tr1, tr2))) end; | _ -> @@ -2743,7 +2745,7 @@ let report_error ppf = function | Constructor_arity_mismatch(lid, expected, provided) -> fprintf ppf "@[The constructor %a@ expects %i argument(s),@ \ - but is here applied to %i argument(s)@]" + but is applied here to %i argument(s)@]" longident lid expected provided | Label_mismatch(lid, trace) -> report_unification_error ppf trace @@ -2751,13 +2753,13 @@ let report_error ppf = function fprintf ppf "The record field label %a@ belongs to the type" longident lid) (function ppf -> - fprintf ppf "but is here mixed with labels of type") + fprintf ppf "but is mixed here with labels of type") | Pattern_type_clash trace -> report_unification_error ppf trace (function ppf -> fprintf ppf "This pattern matches values of type") (function ppf -> - fprintf ppf "but is here used to match values of type") + fprintf ppf "but a pattern was expected which matches values of type") | Multiply_bound_variable name -> fprintf ppf "Variable %s is bound several times in this matching" name | Orpat_vars id -> @@ -2768,15 +2770,15 @@ let report_error ppf = function (function ppf -> fprintf ppf "This expression has type") (function ppf -> - fprintf ppf "but is here used with type") + fprintf ppf "but an expression was expected of type") | Apply_non_function typ -> begin match (repr typ).desc with Tarrow _ -> - fprintf ppf "This function is applied to too many arguments,@ "; + fprintf ppf "This function is applied to too many arguments;@ "; fprintf ppf "maybe you forgot a `;'" | _ -> fprintf ppf - "This expression is not a function, it cannot be applied" + "This expression is not a function; it cannot be applied" end | Apply_wrong_label (l, ty) -> let print_label ppf = function @@ -2786,7 +2788,7 @@ let report_error ppf = function in reset_and_mark_loops ty; fprintf ppf - "@[<v>@[<2>Expecting function has type@ %a@]@.\ + "@[<v>@[<2>The function applied to this argument has type@ %a@]@.\ This argument cannot be applied %a@]" type_expr ty print_label l | Label_multiply_defined lid -> @@ -2814,14 +2816,14 @@ let report_error ppf = function | Unbound_class cl -> fprintf ppf "Unbound class %a" longident cl | Virtual_class cl -> - fprintf ppf "One cannot create instances of the virtual class %a" + fprintf ppf "Cannot instantiate the virtual class %a" longident cl | Unbound_instance_variable v -> fprintf ppf "Unbound instance variable %s" v | Instance_variable_not_mutable v -> fprintf ppf "The instance variable %s is not mutable" v | Not_subtype(tr1, tr2) -> - report_subtyping_error ppf tr1 "is not a subtype of type" tr2 + report_subtyping_error ppf tr1 "is not a subtype of" tr2 | Outside_class -> fprintf ppf "This object duplication occurs outside a method definition" | Value_multiply_overridden v -> @@ -2852,8 +2854,8 @@ let report_error ppf = function end | Abstract_wrong_label (l, ty) -> let label_mark = function - | "" -> "but its first argument is not labeled" - | l -> sprintf "but its first argument is labeled ~%s" l in + | "" -> "but its first argument is not labelled" + | l -> sprintf "but its first argument is labelled ~%s" l in reset_and_mark_loops ty; fprintf ppf "@[<v>@[<2>This function should have type@ %a@]@,%s@]" type_expr ty (label_mark l) diff --git a/typing/typedecl.ml b/typing/typedecl.ml index cdf77652ac..8bad0ef504 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -41,6 +41,7 @@ type error = | Bad_variance of int * (bool * bool) * (bool * bool) | Unavailable_type_constructor of Path.t | Bad_fixed_type of string + | Unbound_type_var_exc of type_expr * type_expr exception Error of Location.t * error @@ -510,14 +511,13 @@ let compute_variance_decl env check decl (required, loc) = compute_variance env tvl true cn cn ty) ftl end; - let priv = decl.type_private - and required = + let required = List.map (fun (c,n as r) -> if c || n then r else (true,true)) required in List.iter2 (fun (ty, co, cn, ct) (c, n) -> - if ty.desc <> Tvar || priv = Private then begin + if ty.desc <> Tvar then begin co := c; cn := n; ct := n; compute_variance env tvl2 c n n ty end) @@ -536,6 +536,7 @@ let compute_variance_decl env check decl (required, loc) = incr pos; if !co && not c || !cn && not n then raise (Error(loc, Bad_variance (!pos, (!co,!cn), (c,n)))); + if decl.type_private = Private then (c,n,n) else let ct = if decl.type_kind = Type_abstract then ct else cn in (!co, !cn, !ct)) tvl0 required @@ -687,10 +688,16 @@ let transl_type_decl env name_sdecl_list = (final_decls, final_env) (* Translate an exception declaration *) +let transl_closed_type env sty = + let ty = transl_simple_type env true sty in + match Ctype.free_variables ty with + | [] -> ty + | tv :: _ -> raise (Error (sty.ptyp_loc, Unbound_type_var_exc (tv, ty))) + let transl_exception env excdecl = reset_type_variables(); Ctype.begin_def(); - let types = List.map (transl_simple_type env true) excdecl in + let types = List.map (transl_closed_type env) excdecl in Ctype.end_def(); List.iter Ctype.generalize types; types @@ -820,6 +827,38 @@ let check_recmod_typedecl env loc recmod_ids path decl = open Format +let explain_unbound ppf tv tl typ kwd lab = + try + let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in + let ty0 = (* Hack to force aliasing when needed *) + Btype.newgenty (Tobject(tv, ref None)) in + Printtyp.reset_and_mark_loops_list [typ ti; ty0]; + fprintf ppf + ".@.@[<hov2>In %s@ %s%a@;<1 -2>the variable %a is unbound@]" + kwd (lab ti) Printtyp.type_expr (typ ti) Printtyp.type_expr tv + with Not_found -> () + +let explain_unbound_single ppf tv ty = + let trivial ty = + explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") in + match (Ctype.repr ty).desc with + Tobject(fi,_) -> + let (tl, rv) = Ctype.flatten_fields fi in + if rv == tv then trivial ty else + explain_unbound ppf tv tl (fun (_,_,t) -> t) + "method" (fun (lab,_,_) -> lab ^ ": ") + | Tvariant row -> + let row = Btype.row_repr row in + if row.row_more == tv then trivial ty else + explain_unbound ppf tv row.row_fields + (fun (l,f) -> match Btype.row_field_repr f with + Rpresent (Some t) -> t + | Reither (_,[t],_,_) -> t + | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl) + | _ -> Btype.newgenty (Ttuple[])) + "case" (fun (lab,_) -> "`" ^ lab ^ " of ") + | _ -> trivial ty + let report_error ppf = function | Repeated_parameter -> fprintf ppf "A type parameter occurs several times" @@ -860,56 +899,30 @@ let report_error ppf = function (function ppf -> fprintf ppf "This type constructor expands to type") (function ppf -> - fprintf ppf "but is here used with type") + fprintf ppf "but is used here with type") | Null_arity_external -> fprintf ppf "External identifiers must be functions" | Missing_native_external -> fprintf ppf "@[<hv>An external function with more than 5 arguments \ - requires second stub function@ \ + requires a second stub function@ \ for native-code compilation@]" | Unbound_type_var (ty, decl) -> fprintf ppf "A type variable is unbound in this type declaration"; let ty = Ctype.repr ty in - let explain tl typ kwd lab = - let ti = List.find (fun ti -> Ctype.deep_occur ty (typ ti)) tl in - let ty0 = (* Hack to force aliasing when needed *) - Btype.newgenty (Tobject(ty, ref None)) in - Printtyp.reset_and_mark_loops_list [typ ti; ty0]; - fprintf ppf - ".@.@[<hov2>In %s@ %s%a@;<1 -2>the variable %a is unbound@]" - kwd (lab ti) Printtyp.type_expr (typ ti) Printtyp.type_expr ty - in - begin try match decl.type_kind, decl.type_manifest with + begin match decl.type_kind, decl.type_manifest with Type_variant tl, _ -> - explain tl (fun (_,tl) -> Btype.newgenty (Ttuple tl)) + explain_unbound ppf ty tl (fun (_,tl) -> Btype.newgenty (Ttuple tl)) "case" (fun (lab,_) -> lab ^ " of ") | Type_record (tl, _), _ -> - explain tl (fun (_,_,t) -> t) + explain_unbound ppf ty tl (fun (_,_,t) -> t) "field" (fun (lab,_,_) -> lab ^ ": ") | Type_abstract, Some ty' -> - let trivial ty = - explain [ty] (fun t -> t) "definition" (fun _ -> "") in - begin match (Ctype.repr ty').desc with - Tobject(fi,_) -> - let (tl, rv) = Ctype.flatten_fields fi in - if rv == ty then trivial ty' else - explain tl (fun (_,_,t) -> t) - "method" (fun (lab,_,_) -> lab ^ ": ") - | Tvariant row -> - let row = Btype.row_repr row in - if row.row_more == ty then trivial ty' else - explain row.row_fields - (fun (l,f) -> match Btype.row_field_repr f with - Rpresent (Some t) -> t - | Reither (_,[t],_,_) -> t - | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl) - | _ -> Btype.newgenty (Ttuple[])) - "case" (fun (lab,_) -> "`" ^ lab ^ " of ") - | _ -> trivial ty' - end + explain_unbound_single ppf ty ty' | _ -> () - with Not_found -> () end + | Unbound_type_var_exc (tv, ty) -> + fprintf ppf "A type variable is unbound in this exception declaration"; + explain_unbound_single ppf (Ctype.repr tv) ty | Unbound_exception lid -> fprintf ppf "Unbound exception constructor@ %a" Printtyp.longident lid | Not_an_exception lid -> @@ -922,16 +935,24 @@ let report_error ppf = function | (false,true) -> "contravariant" | (false,false) -> "unrestricted" in + let suffix n = + let teen = (n mod 100)/10 = 1 in + match n mod 10 with + | 1 when not teen -> "st" + | 2 when not teen -> "nd" + | 3 when not teen -> "rd" + | _ -> "th" + in if n < 1 then fprintf ppf "%s@ %s@ %s" "In this definition, a type variable" "has a variance that is not reflected" - "by its occurence in type parameters." + "by its occurrence in type parameters." else fprintf ppf "%s@ %s@ %s %d%s %s %s,@ %s %s" "In this definition, expected parameter" "variances are not satisfied." - "The" n (match n with 1 -> "st" | 2 -> "nd" | 3 -> "rd" | _ -> "th") + "The" n (suffix n) "type parameter was expected to be" (variance v2) "but it is" (variance v1) | Unavailable_type_constructor p -> diff --git a/typing/typedecl.mli b/typing/typedecl.mli index e23434c7f0..5bb928b1ea 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -75,6 +75,7 @@ type error = | Bad_variance of int * (bool*bool) * (bool*bool) | Unavailable_type_constructor of Path.t | Bad_fixed_type of string + | Unbound_type_var_exc of type_expr * type_expr exception Error of Location.t * error diff --git a/typing/typemod.ml b/typing/typemod.ml index 389e34381e..33b56dca3c 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -920,7 +920,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = (str, coercion) end else begin check_nongen_schemes finalenv str; - normalize_signature finalenv sg; + normalize_signature finalenv simple_sg; let coercion = Includemod.compunit sourcefile sg "(inferred signature)" simple_sg in diff --git a/typing/typetexp.ml b/typing/typetexp.ml index fa3f0c895a..ec2b7ed8df 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -355,12 +355,8 @@ let rec transl_type env policy styp = row_fixed = false; row_name = !name } in let static = Btype.static_row row in let row = - if static then row else - match policy with - Fixed -> - raise (Error (styp.ptyp_loc, Unbound_type_variable "..")) - | Extensible -> row - | Univars -> { row with row_more = new_pre_univar () } + if static || policy <> Univars then row + else { row with row_more = new_pre_univar () } in newty (Tvariant row) | Ptyp_poly(vars, st) -> @@ -392,12 +388,8 @@ and transl_fields env policy = function [] -> newty Tnil - | ({pfield_desc = Pfield_var} as pf)::_ -> - begin match policy with - Fixed -> raise (Error (pf.pfield_loc, Unbound_type_variable "..")) - | Extensible -> newvar () - | Univars -> new_pre_univar () - end + | {pfield_desc = Pfield_var}::_ -> + if policy = Univars then new_pre_univar () else newvar () | {pfield_desc = Pfield(s, e)}::l -> let ty1 = transl_type env policy e in let ty2 = transl_fields env policy l in @@ -556,7 +548,7 @@ let report_error ppf = function Printtyp.type_expr ty | Variant_tags (lab1, lab2) -> fprintf ppf - "Variant tags `%s@ and `%s have same hash value.@ Change one of them." + "Variant tags `%s@ and `%s have the same hash value.@ Change one of them." lab1 lab2 | Invalid_variable_name name -> fprintf ppf "The type variable name %s is not allowed in programs" name diff --git a/utils/agraph.ml b/utils/agraph.ml index 53f2de1c76..4fbfecaa18 100644 --- a/utils/agraph.ml +++ b/utils/agraph.ml @@ -126,18 +126,19 @@ let dump_info chan g s print_info = module Bag = struct -type 'a t = 'a Stack.t + type 'a t = 'a Stack.t -exception Empty + exception Empty + + let create () = Stack.create () + let put b x = Stack.push x b + let get b = + try + Stack.pop b + with + Stack.Empty -> raise Empty + let is_empty b = Stack.is_empty b -let create () = Stack.create () -let put b x = Stack.push x b -let get b = - try - Stack.pop b - with - Stack.Empty -> raise Empty -let is_empty b = Stack.is_empty b end diff --git a/utils/ccomp.ml b/utils/ccomp.ml index 3cb192e318..04472e0c95 100644 --- a/utils/ccomp.ml +++ b/utils/ccomp.ml @@ -54,7 +54,12 @@ let compile_file name = command (Printf.sprintf "%s -c %s %s %s %s" - !Clflags.c_compiler + (match !Clflags.c_compiler with + | Some cc -> cc + | None -> + if !Clflags.native_code + then Config.native_c_compiler + else Config.bytecomp_c_compiler) (String.concat " " (List.rev !Clflags.ccopts)) (quote_prefixed "-I" (List.rev !Clflags.include_dirs)) (Clflags.std_include_flag "-I") @@ -104,15 +109,16 @@ let call_linker mode output_name files extra = extra else Printf.sprintf "%s -o %s %s %s %s %s %s %s" - (match mode with - | Exe -> Config.mkexe - | Dll -> Config.mkdll - | MainDll -> Config.mkmaindll - | Partial -> assert false + (match !Clflags.c_compiler, mode with + | Some cc, _ -> cc + | None, Exe -> Config.mkexe + | None, Dll -> Config.mkdll + | None, MainDll -> Config.mkmaindll + | None, Partial -> assert false ) (Filename.quote output_name) (if !Clflags.gprofile then Config.cc_profile else "") - (Clflags.std_include_flag "-I") + "" (*(Clflags.std_include_flag "-I")*) (quote_prefixed "-L" !Config.load_path) files extra diff --git a/utils/clflags.ml b/utils/clflags.ml index f3248a264a..e498b74b88 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -49,7 +49,7 @@ and principal = ref false (* -principal *) and recursive_types = ref false (* -rectypes *) and make_runtime = ref false (* -make_runtime *) and gprofile = ref false (* -p *) -and c_compiler = ref Config.bytecomp_c_compiler (* -cc *) +and c_compiler = ref (None: string option) (* -cc *) and no_auto_link = ref false (* -noautolink *) and dllpaths = ref ([] : string list) (* -dllpath *) and make_package = ref false (* -pack *) diff --git a/utils/clflags.mli b/utils/clflags.mli index 3463c27768..48f055d813 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -44,7 +44,7 @@ val principal : bool ref val recursive_types : bool ref val make_runtime : bool ref val gprofile : bool ref -val c_compiler : string ref +val c_compiler : string option ref val no_auto_link : bool ref val dllpaths : string list ref val make_package : bool ref diff --git a/utils/config.mlbuild b/utils/config.mlbuild index 18dbbf32ff..ea10032d7a 100644 --- a/utils/config.mlbuild +++ b/utils/config.mlbuild @@ -12,6 +12,16 @@ (* $Id$ *) +(***********************************************************************) +(** **) +(** WARNING WARNING WARNING **) +(** **) +(** When you change this file, you must make the parallel change **) +(** in config.mlp **) +(** **) +(***********************************************************************) + + (* The main OCaml version string has moved to ../VERSION *) let version = Sys.ocaml_version @@ -40,10 +50,8 @@ let standard_runtime = else C.bindir^"/ocamlrun" let ccomp_type = C.ccomptype let bytecomp_c_compiler = sf "%s %s %s" C.bytecc C.bytecccompopts C.sharedcccompopts -let bytecomp_c_linker = if windows then "flexlink" else sf "%s %s" C.bytecc C.bytecclinkopts let bytecomp_c_libraries = C.bytecclibs let native_c_compiler = sf "%s %s" C.nativecc C.nativecccompopts -let native_c_linker = if windows then "flexlink" else sf "%s %s" C.nativecc C.nativecclinkopts let native_c_libraries = C.nativecclibs let native_pack_linker = C.packld let ranlib = C.ranlibcmd @@ -54,8 +62,8 @@ let mkmaindll = C.mkmaindll let exec_magic_number = "Caml1999X008" and cmi_magic_number = "Caml1999I011" -and cmo_magic_number = "Caml1999O006" -and cma_magic_number = "Caml1999A007" +and cmo_magic_number = "Caml1999O007" +and cma_magic_number = "Caml1999A008" and cmx_magic_number = "Caml1999Y011" and cmxa_magic_number = "Caml1999Z010" and ast_impl_magic_number = "Caml1999M012" @@ -102,10 +110,8 @@ let print_config oc = p "standard_runtime" standard_runtime; p "ccomp_type" ccomp_type; p "bytecomp_c_compiler" bytecomp_c_compiler; - p "bytecomp_c_linker" bytecomp_c_linker; p "bytecomp_c_libraries" bytecomp_c_libraries; p "native_c_compiler" native_c_compiler; - p "native_c_linker" native_c_linker; p "native_c_libraries" native_c_libraries; p "native_pack_linker" native_pack_linker; p "ranlib" ranlib; diff --git a/utils/config.mlp b/utils/config.mlp index 90e8390b6f..75d36cc45c 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -12,6 +12,16 @@ (* $Id$ *) +(***********************************************************************) +(** **) +(** WARNING WARNING WARNING **) +(** **) +(** When you change this file, you must make the parallel change **) +(** in config.mlbuild **) +(** **) +(***********************************************************************) + + (* The main OCaml version string has moved to ../VERSION *) let version = Sys.ocaml_version @@ -45,8 +55,8 @@ let mkmaindll = "%%MKMAINDLL%%" let exec_magic_number = "Caml1999X008" and cmi_magic_number = "Caml1999I011" -and cmo_magic_number = "Caml1999O006" -and cma_magic_number = "Caml1999A007" +and cmo_magic_number = "Caml1999O007" +and cma_magic_number = "Caml1999A008" and cmx_magic_number = "Caml1999Y011" and cmxa_magic_number = "Caml1999Z010" and ast_impl_magic_number = "Caml1999M012" diff --git a/utils/tbl.ml b/utils/tbl.ml index 95aa973485..d6689f088d 100644 --- a/utils/tbl.ml +++ b/utils/tbl.ml @@ -95,6 +95,10 @@ let rec iter f = function | Node(l, v, d, r, _) -> iter f l; f v d; iter f r +let rec map f = function + Empty -> Empty + | Node(l, v, d, r, h) -> Node(map f l, v, f v d, map f r, h) + open Format let print print_key print_data ppf tbl = diff --git a/utils/tbl.mli b/utils/tbl.mli index ddeaa79d6a..71c348efae 100644 --- a/utils/tbl.mli +++ b/utils/tbl.mli @@ -23,6 +23,7 @@ val find: 'a -> ('a, 'b) t -> 'b val mem: 'a -> ('a, 'b) t -> bool val remove: 'a -> ('a, 'b) t -> ('a, 'b) t val iter: ('a -> 'b -> 'c) -> ('a, 'b) t -> unit +val map: ('a -> 'b -> 'c) -> ('a, 'b) t -> ('a, 'c) t open Format diff --git a/yacc/reader.c b/yacc/reader.c index 6c8e4a2788..d3c2755720 100644 --- a/yacc/reader.c +++ b/yacc/reader.c @@ -163,6 +163,7 @@ char *substring (char *str, int start, int len) for (i = 0; i < len; i++){ buf[i] = str[start+i]; } + buf[i] = '\0'; /* PR#4796 */ return buf; } @@ -710,7 +711,7 @@ get_literal(void) n = cinc; s = MALLOC(n); if (s == 0) no_space(); - + for (i = 0; i < n; ++i) s[i] = cache[i]; @@ -1306,7 +1307,7 @@ loop: { ++cptr; i = get_number(); - + if (i <= 0 || i > n) unknown_rhs(i); item = pitem[nitems + i - n - 1]; @@ -1393,7 +1394,7 @@ loop: fwrite(cptr, 1, 2, f); cptr += 2; } else - if (cptr[0] == '\\' + if (cptr[0] == '\\' && isdigit((unsigned char) cptr[1]) && isdigit((unsigned char) cptr[2]) && isdigit((unsigned char) cptr[3]) |