diff options
| author | Damien Doligez <damien.doligez-inria.fr> | 2008-12-03 18:09:09 +0000 |
|---|---|---|
| committer | Damien Doligez <damien.doligez-inria.fr> | 2008-12-03 18:09:09 +0000 |
| commit | 1f95b175707ec490f8bf08c6c28f2dee203818cb (patch) | |
| tree | f004cd5ba13d81b1182b65def6f3e20c6bda3798 | |
| parent | c52e649d83e34967da0fd2a70faf5c91070c8a91 (diff) | |
| download | ocaml-1f95b175707ec490f8bf08c6c28f2dee203818cb.tar.gz | |
merge changes from 3.10.2merged to 3.11.0
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@9153 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
88 files changed, 1483 insertions, 702 deletions
@@ -1,3 +1,11 @@ +utils/ccomp.cmi: +utils/clflags.cmi: +utils/config.cmi: +utils/consistbl.cmi: +utils/misc.cmi: +utils/tbl.cmi: +utils/terminfo.cmi: +utils/warnings.cmi: utils/ccomp.cmo: utils/misc.cmi utils/config.cmi utils/clflags.cmi \ utils/ccomp.cmi utils/ccomp.cmx: utils/misc.cmx utils/config.cmx utils/clflags.cmx \ @@ -16,8 +24,11 @@ utils/terminfo.cmo: utils/terminfo.cmi utils/terminfo.cmx: utils/terminfo.cmi utils/warnings.cmo: utils/warnings.cmi utils/warnings.cmx: utils/warnings.cmi +parsing/asttypes.cmi: parsing/lexer.cmi: parsing/parser.cmi parsing/location.cmi +parsing/linenum.cmi: parsing/location.cmi: utils/warnings.cmi +parsing/longident.cmi: parsing/parse.cmi: parsing/parsetree.cmi parsing/parser.cmi: parsing/parsetree.cmi parsing/parsetree.cmi: parsing/longident.cmi parsing/location.cmi \ @@ -59,6 +70,7 @@ typing/ctype.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi \ typing/datarepr.cmi: typing/types.cmi typing/path.cmi parsing/asttypes.cmi typing/env.cmi: typing/types.cmi typing/path.cmi parsing/longident.cmi \ typing/ident.cmi utils/consistbl.cmi typing/annot.cmi +typing/ident.cmi: typing/includeclass.cmi: typing/types.cmi typing/typedtree.cmi typing/env.cmi \ typing/ctype.cmi typing/includecore.cmi: typing/types.cmi typing/typedtree.cmi \ @@ -73,6 +85,7 @@ typing/parmatch.cmi: typing/types.cmi typing/typedtree.cmi \ parsing/location.cmi typing/env.cmi typing/path.cmi: typing/ident.cmi typing/predef.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi +typing/primitive.cmi: typing/printtyp.cmi: typing/types.cmi typing/path.cmi typing/outcometree.cmi \ parsing/longident.cmi typing/ident.cmi typing/stypes.cmi: typing/typedtree.cmi parsing/location.cmi typing/annot.cmi @@ -267,9 +280,12 @@ typing/unused_var.cmx: utils/warnings.cmx parsing/parsetree.cmi \ parsing/longident.cmx parsing/location.cmx parsing/asttypes.cmi \ typing/unused_var.cmi bytecomp/bytegen.cmi: bytecomp/lambda.cmi bytecomp/instruct.cmi +bytecomp/bytelibrarian.cmi: bytecomp/bytelink.cmi: bytecomp/symtable.cmi bytecomp/cmo_format.cmi bytecomp/bytepackager.cmi: typing/ident.cmi +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/lambda.cmi typing/ident.cmi typing/env.cmi @@ -277,17 +293,20 @@ bytecomp/lambda.cmi: typing/types.cmi typing/primitive.cmi typing/path.cmi \ parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi bytecomp/matching.cmi: typing/typedtree.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi +bytecomp/meta.cmi: bytecomp/printinstr.cmi: bytecomp/instruct.cmi bytecomp/printlambda.cmi: bytecomp/lambda.cmi +bytecomp/runtimedef.cmi: bytecomp/simplif.cmi: bytecomp/lambda.cmi +bytecomp/switch.cmi: bytecomp/symtable.cmi: typing/ident.cmi bytecomp/cmo_format.cmi bytecomp/translclass.cmi: typing/typedtree.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi bytecomp/translcore.cmi: typing/types.cmi typing/typedtree.cmi \ typing/primitive.cmi typing/path.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi -bytecomp/translmod.cmi: typing/typedtree.cmi parsing/location.cmi \ - bytecomp/lambda.cmi typing/ident.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/typedtree.cmi typing/path.cmi \ bytecomp/lambda.cmi @@ -329,13 +348,13 @@ 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 bytecomp/dll.cmx: utils/misc.cmx utils/config.cmx bytecomp/dll.cmi -bytecomp/emitcode.cmo: bytecomp/translmod.cmi bytecomp/opcodes.cmo \ - utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \ +bytecomp/emitcode.cmo: bytecomp/translmod.cmi typing/primitive.cmi \ + bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \ bytecomp/instruct.cmi typing/env.cmi utils/config.cmi \ bytecomp/cmo_format.cmi utils/clflags.cmi typing/btype.cmi \ parsing/asttypes.cmi bytecomp/emitcode.cmi -bytecomp/emitcode.cmx: bytecomp/translmod.cmx bytecomp/opcodes.cmx \ - utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.cmx \ +bytecomp/emitcode.cmx: bytecomp/translmod.cmx typing/primitive.cmx \ + bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.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 @@ -351,16 +370,22 @@ bytecomp/lambda.cmx: typing/types.cmx typing/primitive.cmx typing/path.cmx \ parsing/asttypes.cmi bytecomp/lambda.cmi bytecomp/matching.cmo: typing/types.cmi bytecomp/typeopt.cmi \ typing/typedtree.cmi bytecomp/switch.cmi bytecomp/printlambda.cmi \ - typing/primitive.cmi typing/predef.cmi typing/parmatch.cmi utils/misc.cmi \ - parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ - typing/btype.cmi parsing/asttypes.cmi bytecomp/matching.cmi + typing/primitive.cmi typing/predef.cmi typing/path.cmi \ + typing/parmatch.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + bytecomp/matching.cmi bytecomp/matching.cmx: typing/types.cmx bytecomp/typeopt.cmx \ typing/typedtree.cmx bytecomp/switch.cmx bytecomp/printlambda.cmx \ - typing/primitive.cmx typing/predef.cmx typing/parmatch.cmx utils/misc.cmx \ - parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \ - typing/btype.cmx parsing/asttypes.cmi bytecomp/matching.cmi + typing/primitive.cmx typing/predef.cmx typing/path.cmx \ + typing/parmatch.cmx utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + bytecomp/matching.cmi bytecomp/meta.cmo: bytecomp/meta.cmi bytecomp/meta.cmx: bytecomp/meta.cmi +bytecomp/opcodes.cmo: +bytecomp/opcodes.cmx: bytecomp/printinstr.cmo: bytecomp/printlambda.cmi parsing/location.cmi \ bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi \ bytecomp/printinstr.cmi @@ -442,13 +467,17 @@ bytecomp/typeopt.cmx: typing/types.cmx typing/typedtree.cmx \ bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ parsing/asttypes.cmi bytecomp/typeopt.cmi asmcomp/asmgen.cmi: bytecomp/lambda.cmi asmcomp/cmm.cmi +asmcomp/asmlibrarian.cmi: asmcomp/asmlink.cmi: asmcomp/compilenv.cmi +asmcomp/asmpackager.cmi: asmcomp/clambda.cmi: bytecomp/lambda.cmi typing/ident.cmi \ asmcomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/closure.cmi: bytecomp/lambda.cmi asmcomp/clambda.cmi asmcomp/cmmgen.cmi: asmcomp/compilenv.cmi asmcomp/cmm.cmi asmcomp/clambda.cmi asmcomp/cmm.cmi: typing/ident.cmi asmcomp/debuginfo.cmi +asmcomp/cmmgen.cmi: asmcomp/compilenv.cmi asmcomp/cmm.cmi asmcomp/clambda.cmi asmcomp/codegen.cmi: asmcomp/cmm.cmi +asmcomp/coloring.cmi: asmcomp/comballoc.cmi: asmcomp/mach.cmi asmcomp/compilenv.cmi: typing/ident.cmi asmcomp/clambda.cmi asmcomp/debuginfo.cmi: parsing/location.cmi bytecomp/lambda.cmi @@ -478,21 +507,21 @@ asmcomp/arch.cmx: utils/misc.cmx utils/config.cmx asmcomp/asmgen.cmo: bytecomp/translmod.cmi asmcomp/split.cmi \ asmcomp/spill.cmi asmcomp/selection.cmi asmcomp/scheduling.cmi \ asmcomp/reload.cmi asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \ - asmcomp/printlinear.cmi asmcomp/printcmm.cmi utils/misc.cmi \ - asmcomp/mach.cmi asmcomp/liveness.cmi asmcomp/linearize.cmi \ - asmcomp/interf.cmi asmcomp/emitaux.cmi asmcomp/emit.cmi utils/config.cmi \ - asmcomp/compilenv.cmi asmcomp/comballoc.cmi asmcomp/coloring.cmi \ - asmcomp/cmmgen.cmi asmcomp/cmm.cmi asmcomp/closure.cmi utils/clflags.cmi \ - asmcomp/asmgen.cmi + asmcomp/printlinear.cmi asmcomp/printcmm.cmi typing/primitive.cmi \ + utils/misc.cmi asmcomp/mach.cmi asmcomp/liveness.cmi \ + asmcomp/linearize.cmi asmcomp/interf.cmi asmcomp/emitaux.cmi \ + asmcomp/emit.cmi utils/config.cmi asmcomp/compilenv.cmi \ + asmcomp/comballoc.cmi asmcomp/coloring.cmi asmcomp/cmmgen.cmi \ + asmcomp/cmm.cmi asmcomp/closure.cmi utils/clflags.cmi asmcomp/asmgen.cmi asmcomp/asmgen.cmx: bytecomp/translmod.cmx asmcomp/split.cmx \ asmcomp/spill.cmx asmcomp/selection.cmx asmcomp/scheduling.cmx \ asmcomp/reload.cmx asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \ - asmcomp/printlinear.cmx asmcomp/printcmm.cmx utils/misc.cmx \ - asmcomp/mach.cmx asmcomp/liveness.cmx asmcomp/linearize.cmx \ - asmcomp/interf.cmx asmcomp/emitaux.cmx asmcomp/emit.cmx utils/config.cmx \ - asmcomp/compilenv.cmx asmcomp/comballoc.cmx asmcomp/coloring.cmx \ - asmcomp/cmmgen.cmx asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx \ - asmcomp/asmgen.cmi + asmcomp/printlinear.cmx asmcomp/printcmm.cmx typing/primitive.cmx \ + utils/misc.cmx asmcomp/mach.cmx asmcomp/liveness.cmx \ + asmcomp/linearize.cmx asmcomp/interf.cmx asmcomp/emitaux.cmx \ + asmcomp/emit.cmx utils/config.cmx asmcomp/compilenv.cmx \ + asmcomp/comballoc.cmx asmcomp/coloring.cmx asmcomp/cmmgen.cmx \ + asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx asmcomp/asmgen.cmi asmcomp/asmlibrarian.cmo: utils/misc.cmi utils/config.cmi \ asmcomp/compilenv.cmi utils/clflags.cmi asmcomp/clambda.cmi \ utils/ccomp.cmi asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi @@ -662,7 +691,13 @@ asmcomp/split.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/split.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/split.cmi driver/compile.cmi: typing/env.cmi +driver/errors.cmi: +driver/main.cmi: +driver/main_args.cmi: driver/optcompile.cmi: typing/env.cmi +driver/opterrors.cmi: +driver/optmain.cmi: +driver/pparse.cmi: driver/compile.cmo: utils/warnings.cmi typing/unused_var.cmi \ typing/typemod.cmi typing/typedtree.cmi bytecomp/translmod.cmi \ typing/stypes.cmi bytecomp/simplif.cmi typing/printtyp.cmi \ @@ -705,16 +740,16 @@ driver/optcompile.cmo: utils/warnings.cmi typing/unused_var.cmi \ typing/typemod.cmi typing/typedtree.cmi bytecomp/translmod.cmi \ typing/stypes.cmi bytecomp/simplif.cmi typing/printtyp.cmi \ bytecomp/printlambda.cmi parsing/printast.cmi driver/pparse.cmi \ - parsing/parse.cmi utils/misc.cmi typing/ident.cmi typing/env.cmi \ - utils/config.cmi asmcomp/compilenv.cmi utils/clflags.cmi utils/ccomp.cmi \ - asmcomp/asmgen.cmi driver/optcompile.cmi + parsing/parse.cmi utils/misc.cmi parsing/location.cmi typing/ident.cmi \ + typing/env.cmi utils/config.cmi asmcomp/compilenv.cmi utils/clflags.cmi \ + utils/ccomp.cmi asmcomp/asmgen.cmi driver/optcompile.cmi driver/optcompile.cmx: utils/warnings.cmx typing/unused_var.cmx \ typing/typemod.cmx typing/typedtree.cmx bytecomp/translmod.cmx \ typing/stypes.cmx bytecomp/simplif.cmx typing/printtyp.cmx \ bytecomp/printlambda.cmx parsing/printast.cmx driver/pparse.cmx \ - parsing/parse.cmx utils/misc.cmx typing/ident.cmx typing/env.cmx \ - utils/config.cmx asmcomp/compilenv.cmx utils/clflags.cmx utils/ccomp.cmx \ - asmcomp/asmgen.cmx driver/optcompile.cmi + parsing/parse.cmx utils/misc.cmx parsing/location.cmx typing/ident.cmx \ + typing/env.cmx utils/config.cmx asmcomp/compilenv.cmx utils/clflags.cmx \ + utils/ccomp.cmx asmcomp/asmgen.cmx driver/optcompile.cmi driver/opterrors.cmo: utils/warnings.cmi typing/typetexp.cmi \ typing/typemod.cmi typing/typedecl.cmi typing/typecore.cmi \ typing/typeclass.cmi bytecomp/translmod.cmi bytecomp/translcore.cmi \ @@ -751,10 +786,12 @@ toplevel/opttopdirs.cmi: parsing/longident.cmi toplevel/opttoploop.cmi: utils/warnings.cmi typing/types.cmi typing/path.cmi \ parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \ parsing/location.cmi typing/env.cmi +toplevel/opttopmain.cmi: toplevel/topdirs.cmi: parsing/longident.cmi toplevel/toploop.cmi: utils/warnings.cmi typing/types.cmi typing/path.cmi \ parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \ parsing/location.cmi typing/env.cmi +toplevel/topmain.cmi: toplevel/trace.cmi: typing/types.cmi typing/path.cmi parsing/longident.cmi \ typing/env.cmi toplevel/expunge.cmo: bytecomp/symtable.cmi bytecomp/runtimedef.cmi \ @@ -8,17 +8,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 +36,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 +56,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 +67,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. @@ -84,18 +91,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. @@ -110,12 +120,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: @@ -2376,12 +2387,4 @@ Caml Special Light 1.06: * First public release. -<<<<<<< Changes -<<<<<<< Changes -$Id$ -======= -$Id$ ->>>>>>> 1.168.2.7 -======= $Id$ ->>>>>>> 1.168.2.13 @@ -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: @@ -289,7 +289,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 @@ -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: diff --git a/README.win32 b/README.win32 index 8923460e8e..7eac6f262b 100644 --- a/README.win32 +++ b/README.win32 @@ -49,8 +49,7 @@ The remainder of this document gives more information on each port. REQUIREMENTS: -This port runs under MS Windows NT, 2000 and XP. -Windows 95, 98 and ME are no longer supported. +This port runs under MS Windows Vista, XP, and 2000. The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...) runs without any additional tools. @@ -172,8 +171,7 @@ by Jacob Navia, then significantly improved by Christopher A. Watford. REQUIREMENTS: -This port runs under MS Windows NT, 2000 and XP. -Windows 95, 98 and ME are also supported, but less reliably. +This port runs under MS Windows Vista, XP, and 2000. The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...) runs without any additional tools. @@ -1,4 +1,4 @@ -3.12.0+dev0 (2008-10-15) +3.12.0+dev1 (2008-12-03) # The version string is the first line of this file. # It must be in the format described in stdlib/sys.mli diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index c38a73e8c2..4ab379bdaf 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,7 +60,26 @@ 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 && not macosx + then `call {emit_symbol s}@PLT` + else `call {emit_symbol s}` + +let emit_jump s = + if !Clflags.dlcode && not macosx + then `jmp {emit_symbol s}@PLT` + else `jmp {emit_symbol s}` + +let load_symbol_addr s = + if !Clflags.dlcode + then `movq {emit_symbol s}@GOTPCREL(%rip)` + else if !pic_code + then `leaq {emit_symbol s}(%rip)` + else `movq ${emit_symbol s}` + let emit_call s = if !Clflags.dlcode @@ -82,6 +107,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 +614,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 @@ -670,9 +698,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 +750,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`; @@ -733,6 +776,7 @@ let begin_assembly() = 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 +793,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/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/i386/emit.mlp b/asmcomp/i386/emit.mlp index aaaba421a4..7b857a0f73 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -98,7 +98,7 @@ let use_ascii_dir = "solaris" -> false | _ -> true -(* MacOSX has its own way to reference symbols potentially defined in +(* MacOSX has its own way to reference symbols potentially defined in shared objects *) let macosx = @@ -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,7 @@ let fundecl fundecl = bound_error_call := 0; ` .text\n`; emit_align 16; - declare_function_symbol fundecl.fun_name; + ` .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 +898,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 *) @@ -962,6 +959,7 @@ let begin_assembly() = 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`; @@ -981,7 +979,7 @@ let end_assembly() = efa_label_rel = (fun lbl ofs -> ` .long {emit_label lbl} - . + {emit_int32 ofs}\n`); efa_def_label = (fun l -> `{emit_label l}:\n`); - efa_string = (fun s -> + efa_string = (fun s -> let s = s ^ "\000" in if use_ascii_dir then emit_string_directive " .ascii " s 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..3a4a8fc670 100644 --- a/asmrun/signals_osdep.h +++ b/asmrun/signals_osdep.h @@ -49,6 +49,33 @@ #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) + /****************** I386, Linux */ #elif defined(TARGET_i386) && defined(SYS_linux_elf) 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/ocamlc b/boot/ocamlc Binary files differindex 635cd87b63..f71a520fb1 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex 654b5f416a..fb5c37fbe2 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex bbd0d70f16..f6397e72eb 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/build/.cvsignore b/build/.cvsignore new file mode 100644 index 0000000000..274c6e555b --- /dev/null +++ b/build/.cvsignore @@ -0,0 +1 @@ +ocamlbuild_mixed_mode diff --git a/build/camlp4-byte-only.sh b/build/camlp4-byte-only.sh index ab21fd3495..ab98ef50ff 100755 --- a/build/camlp4-byte-only.sh +++ b/build/camlp4-byte-only.sh @@ -1,5 +1,20 @@ #!/bin/sh + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2008 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file LICENSE. # +# # +######################################################################### + # $Id$ + set -e cd `dirname $0`/.. . build/targets.sh diff --git a/build/camlp4-native-only.sh b/build/camlp4-native-only.sh index 42d615880e..d9bdbd1db5 100755 --- a/build/camlp4-native-only.sh +++ b/build/camlp4-native-only.sh @@ -1,5 +1,20 @@ #!/bin/sh + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2008 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file LICENSE. # +# # +######################################################################### + # $Id$ + set -e cd `dirname $0`/.. . build/targets.sh diff --git a/build/fastworld.sh b/build/fastworld.sh index 325af89db1..cdf9ba4ac2 100755 --- a/build/fastworld.sh +++ b/build/fastworld.sh @@ -1,5 +1,20 @@ #!/bin/sh + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2008 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file LICENSE. # +# # +######################################################################### + # $Id$ + cd `dirname $0` set -e if [ -e ocamlbuild_mixed_mode ]; then diff --git a/build/ocamlbuild-byte-only.sh b/build/ocamlbuild-byte-only.sh index 8b010142fc..17f7b87a86 100755 --- a/build/ocamlbuild-byte-only.sh +++ b/build/ocamlbuild-byte-only.sh @@ -1,5 +1,20 @@ #!/bin/sh + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2008 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file LICENSE. # +# # +######################################################################### + # $Id$ + set -e cd `dirname $0`/.. . build/targets.sh diff --git a/build/ocamlbuild-native-only.sh b/build/ocamlbuild-native-only.sh index 823964a7c7..ce96412745 100755 --- a/build/ocamlbuild-native-only.sh +++ b/build/ocamlbuild-native-only.sh @@ -1,5 +1,20 @@ #!/bin/sh + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2008 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file LICENSE. # +# # +######################################################################### + # $Id$ + set -e cd `dirname $0`/.. . build/targets.sh diff --git a/build/ocamlbuildlib-native-only.sh b/build/ocamlbuildlib-native-only.sh index 7afdf72511..a7a570a924 100755 --- a/build/ocamlbuildlib-native-only.sh +++ b/build/ocamlbuildlib-native-only.sh @@ -1,5 +1,20 @@ #!/bin/sh + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2008 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file LICENSE. # +# # +######################################################################### + # $Id$ + set -e cd `dirname $0`/.. . build/targets.sh diff --git a/build/world.sh b/build/world.sh index 2ae1f72fb9..a401e51dbd 100755 --- a/build/world.sh +++ b/build/world.sh @@ -1,5 +1,20 @@ #!/bin/sh + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2008 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file LICENSE. # +# # +######################################################################### + # $Id$ + cd `dirname $0` set -e if [ -e ocamlbuild_mixed_mode ]; then diff --git a/byterun/.depend b/byterun/.depend index 9e2a3d100a..6366bde5c9 100644 --- a/byterun/.depend +++ b/byterun/.depend @@ -117,8 +117,8 @@ stacks.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.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 \ @@ -255,8 +255,8 @@ stacks.d.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.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..ec5f7ab915 100644 --- a/byterun/Makefile +++ b/byterun/Makefile @@ -48,7 +48,7 @@ libcamlrund.a: $(DOBJS) $(RANLIB) libcamlrund.a libcamlrun_shared.so: $(PICOBJS) - $(MKDLL) -o libcamlrun_shared.so $(PICOBJS) + $(MKDLL) -o libcamlrun_shared.so $(PICOBJS) $(BYTECCLIBS) .SUFFIXES: .d.o .pic.o 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/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/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..bc4c88df15 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 6143a565cc..89e0706e24 100644 --- a/byterun/unix.c +++ b/byterun/unix.c @@ -91,7 +91,7 @@ char * caml_search_in_path(struct ext_table * path, char * name) strcpy(fullname, name); return fullname; } - + #ifdef __CYGWIN32__ /* Cygwin needs special treatment because of the implicit ".exe" at the @@ -135,7 +135,7 @@ static char * cygwin_search_exe_in_path(struct ext_table * path, char * name) strcpy(fullname, name); return fullname; } - + #endif char * caml_search_exe_in_path(char * name) diff --git a/config/Makefile.mingw b/config/Makefile.mingw index 0a2bb0a03a..da9330b355 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 a16b86c4df..183ba2d845 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 @@ -260,8 +260,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 @@ -566,20 +568,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*) @@ -625,7 +620,11 @@ case "$host" in i[3456]86-*-solaris*) arch=i386; system=solaris;; 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;; @@ -647,6 +646,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 @@ -685,6 +685,7 @@ 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";; *,gcc*,*,*) nativecccompopts="$gcc_warnings";; esac @@ -696,6 +697,8 @@ 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,*,*) as='as' aspp='gcc -c';; arm,*,*) as='as'; @@ -734,6 +737,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' @@ -1092,27 +1096,27 @@ 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;; *) echo "Cannot detect system stack overflow.";; 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;; +x# Determine the target architecture for the "num" library + +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 diff --git a/debugger/.depend b/debugger/.depend index f56903a38a..afac5c0d53 100644 --- a/debugger/.depend +++ b/debugger/.depend @@ -1,15 +1,22 @@ breakpoints.cmi: primitives.cmi ../bytecomp/instruct.cmi checkpoints.cmi: primitives.cmi debugcom.cmi +command_line.cmi: debugcom.cmi: primitives.cmi +debugger_config.cmi: +dynlink.cmi: envaux.cmi: ../typing/path.cmi ../bytecomp/instruct.cmi ../typing/env.cmi eval.cmi: ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \ ../parsing/longident.cmi ../bytecomp/instruct.cmi ../typing/ident.cmi \ ../typing/env.cmi debugcom.cmi events.cmi: ../bytecomp/instruct.cmi +exec.cmi: frames.cmi: primitives.cmi ../bytecomp/instruct.cmi +history.cmi: input_handling.cmi: primitives.cmi +int64ops.cmi: lexer.cmi: parser.cmi loadprinter.cmi: ../parsing/longident.cmi dynlink.cmi +parameters.cmi: parser.cmi: parser_aux.cmi ../parsing/longident.cmi parser_aux.cmi: primitives.cmi ../parsing/longident.cmi pattern_matching.cmi: ../typing/typedtree.cmi parser_aux.cmi debugcom.cmi @@ -18,10 +25,14 @@ primitives.cmi: ../otherlibs/unix/unix.cmi printval.cmi: ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \ ../typing/env.cmi debugcom.cmi program_loading.cmi: primitives.cmi +program_management.cmi: +question.cmi: show_information.cmi: ../bytecomp/instruct.cmi show_source.cmi: ../bytecomp/instruct.cmi +source.cmi: symbols.cmi: ../bytecomp/instruct.cmi time_travel.cmi: primitives.cmi +trap_barrier.cmi: unix_tools.cmi: ../otherlibs/unix/unix.cmi breakpoints.cmo: symbols.cmi source.cmi primitives.cmi pos.cmi \ ../bytecomp/instruct.cmi exec.cmi debugcom.cmi checkpoints.cmi \ diff --git a/driver/main.ml b/driver/main.ml index d7e11a0d64..eb79f4779a 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -91,7 +91,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 diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 240427ca3f..29afc628dc 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -134,11 +134,13 @@ let implementation ppf sourcefile outputprefix = 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 e8c2f46643..9c464c1e58 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -32,14 +32,14 @@ let process_implementation_file ppf name = let process_file ppf name = if Filename.check_suffix name ".ml" - || Filename.check_suffix name ".mlt" then + || Filename.check_suffix name ".mlt" then process_implementation_file ppf name else if Filename.check_suffix name !Config.interface_suffix then begin let opref = output_prefix name in Optcompile.interface ppf name opref; if !make_package then objfiles := (opref ^ ".cmi") :: !objfiles end - else if Filename.check_suffix name ".cmx" + else if Filename.check_suffix name ".cmx" || Filename.check_suffix name ".cmxa" then objfiles := name :: !objfiles else if Filename.check_suffix name ".cmi" && !make_package then @@ -90,7 +90,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 @ [ @@ -98,7 +97,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), @@ -156,7 +155,7 @@ let main () = " Check principality of type inference"; "-rectypes", Arg.Set recursive_types, " Allow arbitrary recursive types"; - "-shared", Arg.Unit (fun () -> shared := true; dlcode := true), + "-shared", Arg.Unit (fun () -> shared := true; dlcode := true), " Produce a dynlinkable plugin"; "-S", Arg.Set keep_asm_file, " Keep intermediate assembly file"; "-thread", Arg.Set use_threads, diff --git a/emacs/caml-font.el b/emacs/caml-font.el index 2914fdfda0..e796abdcb7 100644 --- a/emacs/caml-font.el +++ b/emacs/caml-font.el @@ -80,11 +80,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 c68d1092c6..4f03b5a582 100644 --- a/emacs/caml.el +++ b/emacs/caml.el @@ -411,10 +411,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) @@ -791,7 +791,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) @@ -804,7 +804,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.") @@ -816,7 +816,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 df3964912a..df03846a15 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 output.cmi: syntax.cmi lexgen.cmi compact.cmi common.cmi outputbis.cmi: syntax.cmi lexgen.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/man/ocamlc.m b/man/ocamlc.m index 20033114e9..a7b3a26702 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -421,9 +421,9 @@ as a preprocessor for each source file. The output of is redirected to an intermediate file, which is compiled. If there are no compilation errors, the intermediate file is deleted afterwards. The name of this -file is built from the basename of the source file with the extension -.ppi for an interface (.mli) file and .ppo for an implementation -(.ml) file. +file is built from the basename of the source file with the +extension .ppi for an interface (.mli) file and .ppo for an +implementation (.ml) file. .TP .B \-principal Check information path during type-checking, to make sure that all @@ -561,7 +561,7 @@ into errors. The compiler will stop with an error when one of these warnings is emitted. The .I warning\-list has the same meaning as for -the "-w" option: an uppercase character turns the corresponding +the "\-w" option: an uppercase character turns the corresponding warning into an error, a lowercase character leaves it as a warning. The default setting is .B \-warn\-error\ a diff --git a/man/ocamlopt.m b/man/ocamlopt.m index ec74a4d7bb..a423146c46 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -1,4 +1,5 @@ \" $Id$ + .TH OCAMLOPT 1 .SH NAME @@ -222,7 +223,7 @@ and edit that file to remove all declarations of unexported names. Add the given directory to the list of directories searched for compiled interface files (.cmi) and compiled object code files (.cmo). By default, the current directory is searched first, then the -standard library directory. Directories added with -I are searched +standard library directory. Directories added with \-I are searched after the current directory, in the order in which they were given on the command line, but before the standard library directory. @@ -536,7 +537,7 @@ into errors. The compiler will stop with an error when one of these warnings is emitted. The .I warning\-list has the same meaning as for -the "-w" option: an uppercase character turns the corresponding +the "\-w" option: an uppercase character turns the corresponding warning into an error, a lowercase character leaves it as a warning. The default setting is .B \-warn\-error\ a @@ -577,7 +578,7 @@ trigonometric operations .BR cos , .BR sin , .B tan -have their range reduced to [-2^64, 2^64]. +have their range reduced to [\-2^64, 2^64]. .SH OPTIONS FOR THE AMD64 ARCHITECTURE diff --git a/man/ocamlrun.m b/man/ocamlrun.m index 1c7e2000cd..6b7c5dfc95 100644 --- a/man/ocamlrun.m +++ b/man/ocamlrun.m @@ -1,4 +1,5 @@ \" $Id$ + .TH OCAMLRUN 1 .SH NAME @@ -104,18 +105,24 @@ record documented in .IR "The Objective Caml user's manual", chapter "Standard Library", section "Gc". .TP -.BR b +.B b Trigger the printing of a stack backtrace when an uncaught exception aborts the program. This option takes no argument. .TP -.BR p +.B p Turn on debugging support for .BR ocamlyacc -generated parsers. When this option is on, the pushdown automaton that executes the parsers prints a trace of its actions. This option takes no argument. .TP +.BR a \ (allocation_policy) +The policy used for allocating in the OCaml heap. Possible values +are 0 for the next-fit policy, and 1 for the first-fit +policy. Next-fit is somewhat faster, but first-fit is better for +avoiding fragmentation and the associated heap compactions. +.TP .BR s \ (minor_heap_size) The size of the minor heap (in words). .TP diff --git a/ocamlbuild/display.ml b/ocamlbuild/display.ml index 9923acaf5f..24c0bd027a 100644 --- a/ocamlbuild/display.ml +++ b/ocamlbuild/display.ml @@ -10,6 +10,7 @@ (***********************************************************************) (* $Id$ *) + (* Original author: Berke Durak *) (* Display *) open My_std;; diff --git a/ocamlbuild/main.ml b/ocamlbuild/main.ml index 852d5614a2..91fc25b53c 100644 --- a/ocamlbuild/main.ml +++ b/ocamlbuild/main.ml @@ -10,6 +10,7 @@ (***********************************************************************) (* $Id$ *) + (* Original author: Berke Durak *) open My_std open Log @@ -279,7 +280,7 @@ let main () = | e -> try Log.eprintf "%a" My_unix.report_error e; - exit 100 + exit 100 with | e -> Log.eprintf "Exception@ %s." (Printexc.to_string e); diff --git a/ocamlbuild/ocaml_specific.ml b/ocamlbuild/ocaml_specific.ml index e785269c47..4dcacff991 100644 --- a/ocamlbuild/ocaml_specific.ml +++ b/ocamlbuild/ocaml_specific.ml @@ -10,6 +10,7 @@ (***********************************************************************) (* $Id$ *) + (* Original author: Nicolas Pouillard *) open My_std open Format diff --git a/ocamlbuild/plugin.ml b/ocamlbuild/plugin.ml index f237d7af59..734a50a517 100644 --- a/ocamlbuild/plugin.ml +++ b/ocamlbuild/plugin.ml @@ -10,6 +10,7 @@ (***********************************************************************) (* $Id$ *) + (* Original author: Nicolas Pouillard *) open My_std open Format @@ -77,7 +78,7 @@ module Make(U:sig end) = let ocamlbuildlib = ocamlbuildlib-.-cma in let ocamlbuild = ocamlbuild-.-cmo in let dir = !Ocamlbuild_where.libdir in - if not (sys_file_exists (dir/ocamlbuildlib)) then + if not (sys_file_exists (dir/ocamlbuildlib)) then failwith (sprintf "Cannot find %S in ocamlbuild -where directory" ocamlbuildlib); let dir = if Pathname.is_implicit dir then Pathname.pwd/dir else dir in let cmd = diff --git a/ocamldoc/.depend b/ocamldoc/.depend index bc82b927d0..9f340ed171 100644 --- a/ocamldoc/.depend +++ b/ocamldoc/.depend @@ -64,6 +64,8 @@ odoc_comments_global.cmo: odoc_comments_global.cmi odoc_comments_global.cmx: odoc_comments_global.cmi odoc_config.cmo: ../utils/config.cmi odoc_config.cmi odoc_config.cmx: ../utils/config.cmx odoc_config.cmi +odoc_control.cmo: +odoc_control.cmx: odoc_cross.cmo: odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_search.cmi \ odoc_scan.cmo odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ odoc_misc.cmi odoc_messages.cmo odoc_exception.cmo odoc_class.cmo \ @@ -104,10 +106,14 @@ odoc_info.cmx: ../typing/printtyp.cmx odoc_value.cmx odoc_types.cmx \ odoc_misc.cmx odoc_messages.cmx odoc_global.cmx odoc_exception.cmx \ odoc_dep.cmx odoc_config.cmx odoc_comments.cmx odoc_class.cmx \ odoc_args.cmx odoc_analyse.cmx odoc_info.cmi +odoc_inherit.cmo: +odoc_inherit.cmx: odoc_latex.cmo: odoc_to_text.cmo odoc_messages.cmo odoc_latex_style.cmo \ odoc_info.cmi ../parsing/asttypes.cmi odoc_latex.cmx: odoc_to_text.cmx odoc_messages.cmx odoc_latex_style.cmx \ odoc_info.cmx ../parsing/asttypes.cmi +odoc_latex_style.cmo: +odoc_latex_style.cmx: odoc_lexer.cmo: odoc_parser.cmi odoc_messages.cmo odoc_comments_global.cmi \ odoc_args.cmi odoc_lexer.cmx: odoc_parser.cmx odoc_messages.cmx odoc_comments_global.cmx \ @@ -138,6 +144,8 @@ odoc_name.cmo: ../typing/path.cmi odoc_misc.cmi ../typing/ident.cmi \ odoc_name.cmi odoc_name.cmx: ../typing/path.cmx odoc_misc.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 \ @@ -166,18 +174,18 @@ odoc_see_lexer.cmo: odoc_parser.cmi odoc_see_lexer.cmx: odoc_parser.cmx odoc_sig.cmo: ../typing/types.cmi ../typing/typedtree.cmi ../typing/path.cmi \ ../parsing/parsetree.cmi odoc_value.cmo odoc_types.cmi odoc_type.cmo \ - odoc_print.cmi odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ - odoc_misc.cmi odoc_messages.cmo odoc_merge.cmi odoc_global.cmi \ - odoc_exception.cmo odoc_env.cmi odoc_class.cmo odoc_args.cmi \ - ../utils/misc.cmi ../parsing/location.cmi ../typing/btype.cmi \ - ../parsing/asttypes.cmi odoc_sig.cmi + odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_misc.cmi \ + odoc_messages.cmo odoc_merge.cmi odoc_global.cmi odoc_exception.cmo \ + odoc_env.cmi odoc_class.cmo odoc_args.cmi ../utils/misc.cmi \ + ../parsing/location.cmi ../typing/btype.cmi ../parsing/asttypes.cmi \ + odoc_sig.cmi odoc_sig.cmx: ../typing/types.cmx ../typing/typedtree.cmx ../typing/path.cmx \ ../parsing/parsetree.cmi odoc_value.cmx odoc_types.cmx odoc_type.cmx \ - odoc_print.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ - odoc_misc.cmx odoc_messages.cmx odoc_merge.cmx odoc_global.cmx \ - odoc_exception.cmx odoc_env.cmx odoc_class.cmx odoc_args.cmx \ - ../utils/misc.cmx ../parsing/location.cmx ../typing/btype.cmx \ - ../parsing/asttypes.cmi odoc_sig.cmi + odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_misc.cmx \ + odoc_messages.cmx odoc_merge.cmx odoc_global.cmx odoc_exception.cmx \ + odoc_env.cmx odoc_class.cmx odoc_args.cmx ../utils/misc.cmx \ + ../parsing/location.cmx ../typing/btype.cmx ../parsing/asttypes.cmi \ + odoc_sig.cmi odoc_str.cmo: ../typing/types.cmi ../typing/printtyp.cmi odoc_value.cmo \ odoc_type.cmo odoc_print.cmi odoc_name.cmi odoc_misc.cmi \ odoc_messages.cmo odoc_exception.cmo odoc_class.cmo \ @@ -217,9 +225,12 @@ odoc_args.cmi: odoc_types.cmi odoc_module.cmo odoc_ast.cmi: ../typing/types.cmi ../typing/typedtree.cmi ../typing/path.cmi \ ../parsing/parsetree.cmi odoc_sig.cmi odoc_name.cmi odoc_module.cmo odoc_comments.cmi: odoc_types.cmi odoc_module.cmo +odoc_comments_global.cmi: +odoc_config.cmi: odoc_cross.cmi: odoc_types.cmi odoc_module.cmo odoc_dag2html.cmi: odoc_info.cmi odoc_env.cmi: ../typing/types.cmi odoc_name.cmi +odoc_global.cmi: odoc_info.cmi: ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ odoc_type.cmo odoc_search.cmi odoc_parameter.cmo odoc_module.cmo \ odoc_exception.cmo odoc_class.cmo ../parsing/asttypes.cmi @@ -237,3 +248,4 @@ odoc_str.cmi: ../typing/types.cmi odoc_value.cmo odoc_type.cmo \ odoc_exception.cmo odoc_class.cmo odoc_text.cmi: odoc_types.cmi odoc_text_parser.cmi: odoc_types.cmi +odoc_types.cmi: diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index 81cf904ce7..dd32d64ae1 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -275,7 +275,7 @@ class virtual text = None else match s.[n] with - | '\n' -> iter_first (n+1) + | '\n' -> iter_first (n+1) | _ -> Some n in match iter_first 0 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/otherlibs/bigarray/.depend b/otherlibs/bigarray/.depend index 40f215e71e..eb76fc5f30 100644 --- a/otherlibs/bigarray/.depend +++ b/otherlibs/bigarray/.depend @@ -27,5 +27,6 @@ mmap_win32.o: mmap_win32.c bigarray.h ../../byterun/config.h \ ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/misc.h \ ../../byterun/mlvalues.h ../../byterun/sys.h ../../byterun/misc.h \ ../unix/unixsupport.h +bigarray.cmi: bigarray.cmo: bigarray.cmi bigarray.cmx: bigarray.cmi diff --git a/otherlibs/bigarray/bigarray.h b/otherlibs/bigarray/bigarray.h index bedc09c000..407a537767 100644 --- a/otherlibs/bigarray/bigarray.h +++ b/otherlibs/bigarray/bigarray.h @@ -90,5 +90,6 @@ CAMLBAextern value caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim); CAMLBAextern value caml_ba_alloc_dims(int flags, int num_dims, void * data, ... /*dimensions, with type intnat */); +CAMLBAextern uintnat caml_ba_byte_size(struct caml_ba_array * b); #endif diff --git a/otherlibs/bigarray/bigarray_stubs.c b/otherlibs/bigarray/bigarray_stubs.c index aa782ed525..9de2def197 100644 --- a/otherlibs/bigarray/bigarray_stubs.c +++ b/otherlibs/bigarray/bigarray_stubs.c @@ -56,7 +56,7 @@ int caml_ba_element_size[] = /* Compute the number of bytes for the elements of a big array */ -uintnat caml_ba_byte_size(struct caml_ba_array * b) +CAMLexport uintnat caml_ba_byte_size(struct caml_ba_array * b) { return caml_ba_num_elts(b) * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK]; @@ -201,7 +201,7 @@ CAMLprim value caml_ba_create(value vkind, value vlayout, value vdim) caml_invalid_argument("Bigarray.create: bad number of dimensions"); for (i = 0; i < num_dims; i++) { dim[i] = Long_val(Field(vdim, i)); - if (dim[i] < 0) + if (dim[i] < 0) caml_invalid_argument("Bigarray.create: negative dimension"); } flags = Int_val(vkind) | Int_val(vlayout); @@ -697,7 +697,7 @@ static void caml_ba_serialize_longarray(void * data, caml_serialize_block_8(data, num_elts); } else { caml_serialize_int_1(0); - for (n = 0, p = data; n < num_elts; n++, p++) + for (n = 0, p = data; n < num_elts; n++, p++) caml_serialize_int_4((int32) *p); } #else @@ -765,7 +765,7 @@ static void caml_ba_deserialize_longarray(void * dest, intnat num_elts) caml_deserialize_block_8(dest, num_elts); } else { intnat * p, n; - for (n = 0, p = dest; n < num_elts; n++, p++) + for (n = 0, p = dest; n < num_elts; n++, p++) *p = caml_deserialize_sint_4(); } #else diff --git a/otherlibs/dbm/.depend b/otherlibs/dbm/.depend index 6fa318eed6..2092fbac64 100644 --- a/otherlibs/dbm/.depend +++ b/otherlibs/dbm/.depend @@ -1,2 +1,3 @@ +dbm.cmi: dbm.cmo: dbm.cmi dbm.cmx: dbm.cmi diff --git a/otherlibs/graph/.depend b/otherlibs/graph/.depend index 32bfc3239e..d890515361 100644 --- a/otherlibs/graph/.depend +++ b/otherlibs/graph/.depend @@ -144,6 +144,8 @@ text.o: text.c libgraph.h \ ../../byterun/config.h ../../byterun/alloc.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ ../../byterun/mlvalues.h +graphics.cmi: +graphicsX11.cmi: graphics.cmo: graphics.cmi graphics.cmx: graphics.cmi graphicsX11.cmo: graphics.cmi graphicsX11.cmi diff --git a/otherlibs/labltk/browser/Makefile.nt b/otherlibs/labltk/browser/Makefile.nt index 12550fe8cb..405f47e746 100644 --- a/otherlibs/labltk/browser/Makefile.nt +++ b/otherlibs/labltk/browser/Makefile.nt @@ -1,14 +1,19 @@ +# $Id$ + OTHERSLIB=-I $(OTHERS)/win32unix -I $(OTHERS)/str -I $(OTHERS)/systhreads CCFLAGS=-I../../../byterun $(TK_DEFS) +include ../support/Makefile.common + ifeq ($(CCOMPTYPE),cc) -WINDOWS_APP=-ccopt "-Wl,--subsystem,windows" +WINDOWS_APP=-ccopt "-link -Wl,--subsystem,windows" else -WINDOWS_APP=-ccopt "/link /subsystem:windows" +WINDOWS_APP=-ccopt "-link /subsystem:windows" endif -OCAMLBR=threads.cma winmain.$(O) $(WINDOWS_APP) +XTRAOBJ=winmain.$(O) +XTRALIBS=threads.cma -custom $(WINDOWS_APP) include Makefile.shared diff --git a/otherlibs/labltk/browser/winmain.c b/otherlibs/labltk/browser/winmain.c index b647fb79b7..dd9146fcce 100644 --- a/otherlibs/labltk/browser/winmain.c +++ b/otherlibs/labltk/browser/winmain.c @@ -1,18 +1,26 @@ +/* $Id$ */ + #include <windows.h> #include <mlvalues.h> #include <callback.h> #include <sys.h> -CAMLextern int __argc; -CAMLextern char **__argv; -CAMLextern void caml_expand_command_line(int * argcp, char *** argvp); +/*CAMLextern int __argc; */ +/* CAMLextern char **__argv; */ +/* CAMLextern void caml_expand_command_line(int * argcp, char *** argvp); */ /* extern void caml_main (char **); */ int WINAPI WinMain(HINSTANCE h, HINSTANCE HPrevInstance, LPSTR lpCmdLine, int nCmdShow) { - caml_expand_command_line(&__argc, &__argv); - caml_main(__argv); + char exe_name[1024]; + char * argv[2]; + + GetModuleFileName(NULL, exe_name, sizeof(exe_name) - 1); + exe_name[sizeof(exe_name) - 1] = '0'; + argv[0] = exe_name; + argv[1] = NULL; + caml_main(argv); sys_exit(Val_int(0)); return 0; } diff --git a/otherlibs/num/.depend b/otherlibs/num/.depend index 6fa1caf7b2..51dcc1cfa5 100644 --- a/otherlibs/num/.depend +++ b/otherlibs/num/.depend @@ -27,7 +27,11 @@ nat_stubs.o: nat_stubs.c ../../byterun/alloc.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 bng.h nat.h +arith_flags.cmi: +arith_status.cmi: big_int.cmi: nat.cmi +int_misc.cmi: +nat.cmi: num.cmi: ratio.cmi nat.cmi big_int.cmi ratio.cmi: nat.cmi big_int.cmi arith_flags.cmo: arith_flags.cmi diff --git a/otherlibs/str/.depend b/otherlibs/str/.depend index 43b299de4b..bafddbd705 100644 --- a/otherlibs/str/.depend +++ b/otherlibs/str/.depend @@ -12,5 +12,6 @@ strstubs.o: strstubs.c ../../byterun/mlvalues.h \ ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ ../../byterun/mlvalues.h +str.cmi: str.cmo: str.cmi str.cmx: str.cmi diff --git a/otherlibs/systhreads/.depend b/otherlibs/systhreads/.depend index 4f4e3162bf..fa6bbbda36 100644 --- a/otherlibs/systhreads/.depend +++ b/otherlibs/systhreads/.depend @@ -23,6 +23,10 @@ posix.o: posix.c ../../byterun/alloc.h ../../byterun/compatibility.h \ ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/sys.h \ ../../byterun/misc.h condition.cmi: mutex.cmi +event.cmi: +mutex.cmi: +thread.cmi: +threadUnix.cmi: condition.cmo: mutex.cmi condition.cmi condition.cmx: mutex.cmx condition.cmi event.cmo: mutex.cmi condition.cmi event.cmi @@ -33,3 +37,7 @@ thread.cmo: thread.cmi thread.cmx: thread.cmi threadUnix.cmo: thread.cmi threadUnix.cmi threadUnix.cmx: thread.cmx threadUnix.cmi +thread_posix.cmo: +thread_posix.cmx: +thread_win32.cmo: +thread_win32.cmx: diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend index e1a829fa8a..919e09221d 100644 --- a/otherlibs/threads/.depend +++ b/otherlibs/threads/.depend @@ -22,6 +22,8 @@ scheduler.o: scheduler.c ../../byterun/alloc.h \ ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/sys.h \ ../../byterun/misc.h condition.cmi: mutex.cmi +event.cmi: +mutex.cmi: thread.cmi: unix.cmo threadUnix.cmi: unix.cmo condition.cmo: thread.cmi mutex.cmi condition.cmi @@ -38,3 +40,5 @@ thread.cmo: unix.cmo thread.cmi thread.cmx: unix.cmx thread.cmi threadUnix.cmo: unix.cmo thread.cmi threadUnix.cmi threadUnix.cmx: unix.cmx thread.cmx threadUnix.cmi +unix.cmo: +unix.cmx: diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend index b0ec616931..2c589e92b9 100644 --- a/otherlibs/unix/.depend +++ b/otherlibs/unix/.depend @@ -656,6 +656,11 @@ sockopt.o: sockopt.c ../../byterun/mlvalues.h \ ../../byterun/../config/m.h ../../byterun/../config/s.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/memory.h ../../byterun/compatibility.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 \ + ../../byterun/misc.h ../../byterun/misc.h ../../byterun/mlvalues.h \ ../../byterun/alloc.h ../../byterun/compatibility.h \ ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ @@ -783,6 +788,7 @@ write.o: write.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ ../../byterun/mlvalues.h unixsupport.h +unix.cmi: unixLabels.cmi: unix.cmi unix.cmo: unix.cmi unix.cmx: unix.cmi diff --git a/otherlibs/win32unix/lockf.c b/otherlibs/win32unix/lockf.c index 0494d635c0..524f9516b6 100644 --- a/otherlibs/win32unix/lockf.c +++ b/otherlibs/win32unix/lockf.c @@ -71,7 +71,7 @@ CAMLprim value unix_lockf(value fd, value cmd, value span) } h = Handle_val(fd); - + l_len = Long_val(span); /* No matter what, we need the current position in the file */ @@ -108,19 +108,19 @@ CAMLprim value unix_lockf(value fd, value cmd, value span) switch(Int_val(cmd)) { case 0: /* F_ULOCK - unlock */ if (! UnlockFileEx(h, 0, - lock_len.LowPart, lock_len.HighPart, &overlap)) + lock_len.LowPart, lock_len.HighPart, &overlap)) err = GetLastError(); break; case 1: /* F_LOCK - blocking write lock */ enter_blocking_section(); if (! LockFileEx(h, LOCKFILE_EXCLUSIVE_LOCK, 0, - lock_len.LowPart, lock_len.HighPart, &overlap)) + lock_len.LowPart, lock_len.HighPart, &overlap)) err = GetLastError(); leave_blocking_section(); break; case 2: /* F_TLOCK - non-blocking write lock */ if (! LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK, 0, - lock_len.LowPart, lock_len.HighPart, &overlap)) + lock_len.LowPart, lock_len.HighPart, &overlap)) err = GetLastError(); break; case 3: /* F_TEST - check whether a write lock can be obtained */ @@ -130,7 +130,7 @@ CAMLprim value unix_lockf(value fd, value cmd, value span) * it is not clear the nature of the lock test performed * by ocaml (unix) currently. */ if (LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK, 0, - lock_len.LowPart, lock_len.HighPart, &overlap)) { + lock_len.LowPart, lock_len.HighPart, &overlap)) { UnlockFileEx(h, 0, lock_len.LowPart, lock_len.HighPart, &overlap); } else { err = GetLastError(); @@ -139,13 +139,13 @@ CAMLprim value unix_lockf(value fd, value cmd, value span) case 4: /* F_RLOCK - blocking read lock */ enter_blocking_section(); if (! LockFileEx(h, 0, 0, - lock_len.LowPart, lock_len.HighPart, &overlap)) + lock_len.LowPart, lock_len.HighPart, &overlap)) err = GetLastError(); leave_blocking_section(); break; case 5: /* F_TRLOCK - non-blocking read lock */ if (! LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY, 0, - lock_len.LowPart, lock_len.HighPart, &overlap)) + lock_len.LowPart, lock_len.HighPart, &overlap)) err = GetLastError(); break; default: diff --git a/otherlibs/win32unix/select.c b/otherlibs/win32unix/select.c index a41d4688dc..0c7760bb7b 100644 --- a/otherlibs/win32unix/select.c +++ b/otherlibs/win32unix/select.c @@ -70,7 +70,9 @@ void handle_set_add (LPSELECTHANDLESET hds, HANDLE hdl) hds->nLast++; } - DBUG_PRINT("Adding handle %x to set %x", hdl, hds); +#ifdef DBUG + dbug_print("Adding handle %x to set %x", hdl, hds); +#endif } BOOL handle_set_mem (LPSELECTHANDLESET hds, HANDLE hdl) @@ -220,7 +222,9 @@ void select_data_free (LPSELECTDATA lpSelectData) { DWORD i; - DBUG_PRINT("Freeing data of %x", lpSelectData); +#ifdef DBUG + dbug_print("Freeing data of %x", lpSelectData); +#endif /* Free APC related data, if they exists */ if (lpSelectData->lpWorker != NULL) @@ -292,7 +296,9 @@ LPSELECTDATA select_data_job_search (LPSELECTDATA *lppSelectData, SELECTTYPE ETy res = NULL; /* Search for job */ - DBUG_PRINT("Searching an available job for type %d", EType); +#ifdef DBUG + dbug_print("Searching an available job for type %d", EType); +#endif res = *lppSelectData; while ( res != NULL @@ -308,7 +314,9 @@ LPSELECTDATA select_data_job_search (LPSELECTDATA *lppSelectData, SELECTTYPE ETy /* No matching job found, create one */ if (res == NULL) { - DBUG_PRINT("No job for type %d found, create one", EType); +#ifdef DBUG + dbug_print("No job for type %d found, create one", EType); +#endif res = select_data_new(*lppSelectData, EType); *lppSelectData = res; } @@ -329,7 +337,9 @@ void read_console_poll(HANDLE hStop, void *_data) LPSELECTDATA lpSelectData; LPSELECTQUERY lpQuery; - DBUG_PRINT("Waiting for data on console"); +#ifdef DBUG + dbug_print("Waiting for data on console"); +#endif record; waitRes = 0; @@ -402,7 +412,9 @@ void read_pipe_poll (HANDLE hStop, void *_data) n = 0; lpSelectData = (LPSELECTDATA)_data; - DBUG_PRINT("Checking data pipe"); +#ifdef DBUG + dbug_print("Checking data pipe"); +#endif while (lpSelectData->EState == SELECT_STATE_NONE) { for (i = 0; i < lpSelectData->nQueriesCount; i++) @@ -440,7 +452,9 @@ void read_pipe_poll (HANDLE hStop, void *_data) } } } - DBUG_PRINT("Finish checking data on pipe"); +#ifdef DBUG + dbug_print("Finish checking data on pipe"); +#endif } /* Add a function to monitor pipe input */ @@ -454,7 +468,9 @@ LPSELECTDATA read_pipe_poll_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, HA worker can handle many pipe. We begin to try to find a worker that is polling pipe, but for which there is under the limit of pipe per worker. */ - DBUG_PRINT("Searching an available worker handling pipe"); +#ifdef DBUG + dbug_print("Searching an available worker handling pipe"); +#endif res = select_data_job_search(&hd, SELECT_TYPE_PIPE_READ); /* Add a new pipe to poll */ @@ -526,7 +542,9 @@ void socket_poll (HANDLE hStop, void *_data) iterQuery = &(lpSelectData->aQueries[i]); if (WaitForSingleObject(aEvents[i], 0) == WAIT_OBJECT_0) { - DBUG_PRINT("Socket %d has pending events", (i - 1)); +#ifdef DBUG + dbug_print("Socket %d has pending events", (i - 1)); +#endif if (iterQuery != NULL) { select_data_result_add(lpSelectData, iterQuery->EMode, iterQuery->lpOrig); @@ -556,14 +574,20 @@ LPSELECTDATA socket_poll_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, HANDL need one worker to use it. Try to find if there is already a worker handling this kind of request. */ - DBUG_PRINT("Scanning list of worker to find one that already handle socket"); +#ifdef DBUG + dbug_print("Scanning list of worker to find one that already handle socket"); +#endif res = select_data_job_search(&hd, SELECT_TYPE_SOCKET); /* Add a new socket to poll */ res->funcWorker = socket_poll; - DBUG_PRINT("Add socket %x to worker", hFileDescr); +#ifdef DBUG + dbug_print("Add socket %x to worker", hFileDescr); +#endif select_data_query_add(res, EMode, hFileDescr, lpOrig); - DBUG_PRINT("Socket %x added", hFileDescr); +#ifdef DBUG + dbug_print("Socket %x added", hFileDescr); +#endif return hd; } @@ -654,9 +678,13 @@ LPSELECTDATA select_data_dispatch (LPSELECTDATA lpSelectData, SELECTMODE EMode, sa_len = sizeof(sa); alreadyAdded = FALSE; - DBUG_PRINT("Begin dispatching handle %x", hFileDescr); +#ifdef DBUG + dbug_print("Begin dispatching handle %x", hFileDescr); +#endif - DBUG_PRINT("Waiting for %d on handle %x", EMode, hFileDescr); +#ifdef DBUG + dbug_print("Waiting for %d on handle %x", EMode, hFileDescr); +#endif /* There is only 2 way to have except mode: transmission of OOB data through a socket TCP/IP and through a strange interaction with a TTY. @@ -665,7 +693,9 @@ LPSELECTDATA select_data_dispatch (LPSELECTDATA lpSelectData, SELECTMODE EMode, switch(get_handle_type(fd)) { case SELECT_HANDLE_DISK: - DBUG_PRINT("Handle %x is a disk handle", hFileDescr); +#ifdef DBUG + dbug_print("Handle %x is a disk handle", hFileDescr); +#endif /* Disk is always ready in read/write operation */ if (EMode == SELECT_MODE_READ || EMode == SELECT_MODE_WRITE) { @@ -674,7 +704,9 @@ LPSELECTDATA select_data_dispatch (LPSELECTDATA lpSelectData, SELECTMODE EMode, break; case SELECT_HANDLE_CONSOLE: - DBUG_PRINT("Handle %x is a console handle", hFileDescr); +#ifdef DBUG + dbug_print("Handle %x is a console handle", hFileDescr); +#endif /* Console is always ready in write operation, need to check for read. */ if (EMode == SELECT_MODE_READ) { @@ -687,28 +719,38 @@ LPSELECTDATA select_data_dispatch (LPSELECTDATA lpSelectData, SELECTMODE EMode, break; case SELECT_HANDLE_PIPE: - DBUG_PRINT("Handle %x is a pipe handle", hFileDescr); +#ifdef DBUG + dbug_print("Handle %x is a pipe handle", hFileDescr); +#endif /* Console is always ready in write operation, need to check for read. */ if (EMode == SELECT_MODE_READ) { - DBUG_PRINT("Need to check availability of data on pipe"); +#ifdef DBUG + dbug_print("Need to check availability of data on pipe"); +#endif res = read_pipe_poll_add(res, EMode, hFileDescr, lpOrig); } else if (EMode == SELECT_MODE_WRITE) { - DBUG_PRINT("No need to check availability of data on pipe, write operation always possible"); +#ifdef DBUG + dbug_print("No need to check availability of data on pipe, write operation always possible"); +#endif res = static_poll_add(res, EMode, hFileDescr, lpOrig); }; break; case SELECT_HANDLE_SOCKET: - DBUG_PRINT("Handle %x is a socket handle", hFileDescr); +#ifdef DBUG + dbug_print("Handle %x is a socket handle", hFileDescr); +#endif if (getsockname((SOCKET)hFileDescr, &sa, &sa_len) == SOCKET_ERROR) { if (WSAGetLastError() == WSAEINVAL) { /* Socket is not bound */ - DBUG_PRINT("Socket is not connected"); +#ifdef DBUG + dbug_print("Socket is not connected"); +#endif if (EMode == SELECT_MODE_WRITE || EMode == SELECT_MODE_READ) { res = static_poll_add(res, EMode, hFileDescr, lpOrig); @@ -723,12 +765,16 @@ LPSELECTDATA select_data_dispatch (LPSELECTDATA lpSelectData, SELECTMODE EMode, break; default: - DBUG_PRINT("Handle %x is unknown", hFileDescr); +#ifdef DBUG + dbug_print("Handle %x is unknown", hFileDescr); +#endif caml_failwith("Unknown handle"); break; }; - DBUG_PRINT("Finish dispatching handle %x", hFileDescr); +#ifdef DBUG + dbug_print("Finish dispatching handle %x", hFileDescr); +#endif CAMLreturnT(LPSELECTDATA, res); } @@ -771,6 +817,9 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value /* Time to wait */ DWORD milliseconds; + /* Is there static select data */ + BOOL hasStaticData = FALSE; + /* Wait return */ DWORD waitRet; @@ -788,7 +837,9 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value CAMLlocal5 (read_list, write_list, except_list, res, l); CAMLlocal1 (fd); - DBUG_PRINT("in select"); +#ifdef DBUG + dbug_print("in select"); +#endif nEventsCount = 0; nEventsMax = 0; @@ -797,6 +848,7 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value iterSelectData = NULL; iterResult = NULL; err = 0; + hasStaticData = 0; waitRet = 0; readfds_len = caml_list_length(readfds); writefds_len = caml_list_length(writefds); @@ -817,7 +869,9 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value if (Double_val(timeout) >= 0.0) { milliseconds = 1000 * Double_val(timeout); - DBUG_PRINT("Will wait %d ms", milliseconds); +#ifdef DBUG + dbug_print("Will wait %d ms", milliseconds); +#endif } else { @@ -826,7 +880,9 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value /* Create list of select data, based on the different list of fd to watch */ - DBUG_PRINT("Dispatch read fd"); +#ifdef DBUG + dbug_print("Dispatch read fd"); +#endif handle_set_init(&hds, hdsData, hdsMax); for (l = readfds; l != Val_int(0); l = Field(l, 1)) { @@ -838,12 +894,16 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value } else { - DBUG_PRINT("Discarding handle %x which is already monitor for read", Handle_val(fd)); +#ifdef DBUG + dbug_print("Discarding handle %x which is already monitor for read", Handle_val(fd)); +#endif } } handle_set_reset(&hds); - DBUG_PRINT("Dispatch write fd"); +#ifdef DBUG + dbug_print("Dispatch write fd"); +#endif handle_set_init(&hds, hdsData, hdsMax); for (l = writefds; l != Val_int(0); l = Field(l, 1)) { @@ -855,12 +915,16 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value } else { - DBUG_PRINT("Discarding handle %x which is already monitor for write", Handle_val(fd)); +#ifdef DBUG + dbug_print("Discarding handle %x which is already monitor for write", Handle_val(fd)); +#endif } } handle_set_reset(&hds); - DBUG_PRINT("Dispatch exceptional fd"); +#ifdef DBUG + dbug_print("Dispatch exceptional fd"); +#endif handle_set_init(&hds, hdsData, hdsMax); for (l = exceptfds; l != Val_int(0); l = Field(l, 1)) { @@ -872,13 +936,17 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value } else { - DBUG_PRINT("Discarding handle %x which is already monitor for exceptional", Handle_val(fd)); +#ifdef DBUG + dbug_print("Discarding handle %x which is already monitor for exceptional", Handle_val(fd)); +#endif } } handle_set_reset(&hds); /* Building the list of handle to wait for */ - DBUG_PRINT("Building events done array"); +#ifdef DBUG + dbug_print("Building events done array"); +#endif nEventsMax = list_length((LPLIST)lpSelectData); nEventsCount = 0; if (!HeapLock(GetProcessHeap())) @@ -892,6 +960,16 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value iterSelectData = lpSelectData; while (iterSelectData != NULL) { + /* Check if it is static data. If this is the case, launch everything + * but don't wait for events. It helps to test if there are events on + * any other fd (which are not static), knowing that there is at least + * one result (the static data). + */ + if (iterSelectData->EType == SELECT_TYPE_STATIC) + { + hasStaticData = TRUE; + }; + /* Execute APC */ if (iterSelectData->funcWorker != NULL) { @@ -899,14 +977,18 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value worker_job_submit( iterSelectData->funcWorker, (void *)iterSelectData); - DBUG_PRINT("Job submitted to worker %x", iterSelectData->lpWorker); +#ifdef DBUG + dbug_print("Job submitted to worker %x", iterSelectData->lpWorker); +#endif lpEventsDone[nEventsCount] = worker_job_event_done(iterSelectData->lpWorker); nEventsCount++; }; iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); }; - DBUG_PRINT("Need to watch %d workers", nEventsCount); +#ifdef DBUG + dbug_print("Need to watch %d workers", nEventsCount); +#endif /* Processing select itself */ enter_blocking_section(); @@ -914,9 +996,11 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value if (nEventsCount > 0) { /* Waiting for event */ - if (err == 0) + if (err == 0 && !hasStaticData) { - DBUG_PRINT("Waiting for one select worker to be done"); +#ifdef DBUG + dbug_print("Waiting for one select worker to be done"); +#endif switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, FALSE, milliseconds)) { case WAIT_FAILED: @@ -924,17 +1008,23 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value break; case WAIT_TIMEOUT: - DBUG_PRINT("Select timeout"); +#ifdef DBUG + dbug_print("Select timeout"); +#endif break; default: - DBUG_PRINT("One worker is done"); +#ifdef DBUG + dbug_print("One worker is done"); +#endif break; }; } /* Ordering stop to every worker */ - DBUG_PRINT("Sending stop signal to every select workers"); +#ifdef DBUG + dbug_print("Sending stop signal to every select workers"); +#endif iterSelectData = lpSelectData; while (iterSelectData != NULL) { @@ -945,7 +1035,9 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); }; - DBUG_PRINT("Waiting for every select worker to be done"); +#ifdef DBUG + dbug_print("Waiting for every select worker to be done"); +#endif switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, TRUE, INFINITE)) { case WAIT_FAILED: @@ -953,22 +1045,28 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value break; default: - DBUG_PRINT("Every worker is done"); +#ifdef DBUG + dbug_print("Every worker is done"); +#endif break; } } /* Nothing to monitor but some time to wait. */ - else + else if (!hasStaticData) { Sleep(milliseconds); } leave_blocking_section(); - DBUG_PRINT("Error status: %d (0 is ok)", err); +#ifdef DBUG + dbug_print("Error status: %d (0 is ok)", err); +#endif /* Build results */ if (err == 0) { - DBUG_PRINT("Building result"); +#ifdef DBUG + dbug_print("Building result"); +#endif read_list = Val_unit; write_list = Val_unit; except_list = Val_unit; @@ -1007,7 +1105,9 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value } /* Free resources */ - DBUG_PRINT("Free selectdata resources"); +#ifdef DBUG + dbug_print("Free selectdata resources"); +#endif iterSelectData = lpSelectData; while (iterSelectData != NULL) { @@ -1018,7 +1118,9 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value lpSelectData = NULL; /* Free allocated events/handle set array */ - DBUG_PRINT("Free local allocated resources"); +#ifdef DBUG + dbug_print("Free local allocated resources"); +#endif if (!HeapLock(GetProcessHeap())) { win32_maperr(GetLastError()); @@ -1028,20 +1130,26 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value HeapFree(GetProcessHeap(), 0, hdsData); HeapUnlock(GetProcessHeap()); - DBUG_PRINT("Raise error if required"); +#ifdef DBUG + dbug_print("Raise error if required"); +#endif if (err != 0) { win32_maperr(err); uerror("select", Nothing); } - DBUG_PRINT("Build final result"); +#ifdef DBUG + dbug_print("Build final result"); +#endif res = alloc_small(3, 0); Store_field(res, 0, read_list); Store_field(res, 1, write_list); Store_field(res, 2, except_list); - DBUG_PRINT("out select"); +#ifdef DBUG + dbug_print("out select"); +#endif CAMLreturn(res); } 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/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/weak.mli b/stdlib/weak.mli index 70fcfa3f54..33f4bf1d0c 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/testlabl/poly.exp b/testlabl/poly.exp index ecd8cad5d4..497cfc6f99 100644 --- a/testlabl/poly.exp +++ b/testlabl/poly.exp @@ -1,4 +1,4 @@ - Objective Caml version 3.10.1+dev0 (2007-05-21) + Objective Caml version 3.11.0+beta1 # * * * # type 'a t = { t : 'a; } # type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; } @@ -122,33 +122,33 @@ val c : circle = <obj> val d : float = 11.4536240470737098 # val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = <fun> # Characters 41-42: -This expression has type < m : 'a. 'a -> 'a list > but is here used with type - < m : 'a. 'a -> 'b > -The universal variable 'a would escape its scope +Error: This expression has type < m : 'a. 'a -> 'a list > + but is here used with type < m : 'a. 'a -> 'b > + The universal variable 'a would escape its scope # class id : object method id : 'a -> 'a end # class type id_spec = object method id : 'a -> 'a end # class id_impl : object method id : 'a -> 'a end # class a : object method m : bool end and b : object method id : 'a -> 'a end # Characters 72-77: -This method has type 'a -> 'a which is less general than 'b. 'b -> 'a +Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a # Characters 75-80: -This method has type 'a -> 'a which is less general than 'b. 'b -> 'a +Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a # Characters 80-85: -This method has type 'a -> 'a which is less general than 'b. 'b -> 'b +Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'b # Characters 92-159: -This method has type 'a -> 'a which is less general than 'b. 'b -> 'b +Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'b # class c : object method m : 'a -> 'b -> 'a end # val f1 : id -> int * bool = <fun> # val f2 : id -> int * bool = <fun> # Characters 24-28: -This expression has type bool but is here used with type int +Error: This expression has type bool but is here used with type int # val f4 : id -> int * bool = <fun> # class c : object method m : #id -> int * bool end # class id2 : object method id : 'a -> 'a method mono : int -> int end # val app : int * bool = (1, true) # Characters 4-25: -The type abbreviation foo is cyclic +Error: The type abbreviation foo is cyclic # class ['a] bar : 'a -> object end # type 'a foo = 'a foo bar # - : (< m : 'b. 'b * 'a > as 'a) -> 'c * 'a = <fun> @@ -211,13 +211,13 @@ class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end # class node : object method as_variant : [> `Node of node_type ] end # type bad = { bad : 'a. 'a option ref; } # Characters 17-25: -This field value has type 'a option ref which is less general than - 'b. 'b option ref +Error: This field value has type 'a option ref which is less general than + 'b. 'b option ref # type bad2 = { mutable bad2 : 'a. 'a option ref option; } # val bad2 : bad2 = {bad2 = None} # Characters 13-28: -This field value has type 'a option ref option which is less general than - 'b. 'b option ref option +Error: This field value has type 'a option ref option + which is less general than 'b. 'b option ref option # val f : < m : 'a. < p : 'a * 'b > as 'b > -> 'c -> unit = <fun> # val f : < m : 'a. 'a * (< p : int * 'b > as 'b) > -> 'b -> unit = <fun> # type 'a t = [ `A of 'a ] @@ -226,36 +226,36 @@ This field value has type 'a option ref option which is less general than # class c : object method m : ([> 'a t ] as 'a) -> 'a end # class c : object method m : ([> `A ] as 'a) option -> 'a end # Characters 145-166: -This type scheme cannot quantify 'a : +Error: This type scheme cannot quantify 'a : it escapes this scope. # type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a > type 'a alist = < visit : 'b. ('b, 'a) list_visitor -> 'b > class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; } # Characters 19-25: -The type abbreviation t is cyclic +Error: The type abbreviation t is cyclic # class ['a] a : object constraint 'a = [> `A of 'a a ] end type t = [ `A of t a ] # Characters 71-80: -Constraints are not satisfied in this type. +Error: Constraints are not satisfied in this type. Type ('a, 'b) t should be an instance of ('c, 'c) t # type 'a t = 'a and u = int t # type 'a t constraint 'a = int # Characters 26-32: -Constraints are not satisfied in this type. +Error: Constraints are not satisfied in this type. Type 'a u t should be an instance of int t # type 'a u = 'a constraint 'a = int and 'a v = 'a u t constraint 'a = int # type g = int # type 'a t = unit constraint 'a = g # Characters 26-32: -Constraints are not satisfied in this type. +Error: Constraints are not satisfied in this type. Type 'a u t should be an instance of g t # type 'a u = 'a constraint 'a = g and 'a v = 'a u t constraint 'a = int # Characters 38-58: -In the definition of v, type 'a list u should be 'a u +Error: In the definition of v, type 'a list u should be 'a u # type 'a t = 'a type 'a u = A of 'a t # type 'a t = < a : 'a > @@ -288,7 +288,7 @@ Characters 21-24: Warning U: this match case is unused. - : int * [< `B ] -> int = <fun> # Characters 69-135: -Constraints are not satisfied in this type. +Error: Constraints are not satisfied in this type. Type ([> `B of 'a ], 'a) b as 'a should be an instance of @@ -328,68 +328,73 @@ Warning X: the following private methods were made public implicitly: n. val f : unit -> < m : int; n : int > = <fun> # Characters 11-56: -This object is expected to have type c but has actually type - < m : int; n : 'a > -The first object type has no method n +Error: This object is expected to have type c but has actually type + < m : int; n : 'a > + The first object type has no method n # Characters 11-69: -This object is expected to have type < n : int > but has actually type - < m : 'a > -The second object type has no method n +Error: This object is expected to have type < n : int > but has actually type + < m : 'a > + The second object type has no method n # Characters 66-124: -This object is expected to have type < x : int; .. > but has actually type - < x : int > -Self type cannot be unified with a closed object type +Error: This object is expected to have type < x : int; .. > + but has actually type < x : int > + Self type cannot be unified with a closed object type # val o : < x : int > = <obj> # Characters 76-77: -This expression has type < m : 'b. 'b * < m : 'b * 'a > > as 'a -but is here used with type - < m : 'b. 'b * (< m : 'b * < m : 'd. 'd * 'c > > as 'c) > -Types for method m are incompatible +Error: This expression has type < m : 'b. 'b * < m : 'b * 'a > > as 'a + but is here used with type + < m : 'b. 'b * (< m : 'b * < m : 'd. 'd * 'c > > as 'c) > + Types for method m are incompatible # Characters 176-177: -This expression has type foo' = < m : 'a. 'a * 'a foo > -but is here used with type bar' = < m : 'a. 'a * 'a bar > -Type 'a foo = < m : 'a * 'a foo > is not compatible with type - 'a bar = < m : 'a * < m : 'b. 'b * 'a bar > > -Type 'a foo = < m : 'a * 'a foo > is not compatible with type - < m : 'b. 'b * 'a bar > -Types for method m are incompatible +Error: This expression has type foo' = < m : 'a. 'a * 'a foo > + but is here used with type bar' = < m : 'a. 'a * 'a bar > + Type 'a foo = < m : 'a * 'a foo > is not compatible with type + 'a bar = < m : 'a * < m : 'b. 'b * 'a bar > > + Type 'a foo = < m : 'a * 'a foo > is not compatible with type + < m : 'b. 'b * 'a bar > + Types for method m are incompatible # Characters 67-68: -This expression has type < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -but is here used with type - < m : 'a. 'a * ('a * < m : 'c. 'c * ('c * 'd) >) > as 'd -Types for method m are incompatible +Error: This expression has type + < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > + but is here used with type + < m : 'a. 'a * ('a * < m : 'c. 'c * ('c * 'd) >) > as 'd + Types for method m are incompatible # Characters 66-67: -This expression has type < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -but is here used with type - < m : 'a. 'a * ('a * < m : 'c. 'c * ('a * 'd) >) > as 'd -Types for method m are incompatible +Error: This expression has type + < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > + but is here used with type + < m : 'a. 'a * ('a * < m : 'c. 'c * ('a * 'd) >) > as 'd + Types for method m are incompatible # Characters 51-52: -This expression has type < m : 'b. 'b * ('b * 'a) > as 'a -but is here used with type < m : 'b. 'b * ('b * < m : 'd. 'd * 'c > as 'c) > -Types for method m are incompatible +Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a + but is here used with type + < m : 'b. 'b * ('b * < m : 'd. 'd * 'c > as 'c) > + Types for method m are incompatible # Characters 14-115: -Type < m : 'a. 'a -> ('a * (< m : 'd. 'd -> 'b as 'e > as 'c) as 'b) > -is not a subtype of type < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f +Error: Type < m : 'a. 'a -> ('a * (< m : 'd. 'd -> 'b as 'e > as 'c) as 'b) > + is not a subtype of type < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f # Characters 88-150: -Signature mismatch: -Modules do not match: - sig val f : (< m : 'b. 'b * ('b * 'a) > as 'a) -> unit end -is not included in - sig val f : < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -> unit end -Values do not match: - val f : (< m : 'b. 'b * ('b * 'a) > as 'a) -> unit -is not included in - val f : < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -> unit +Error: Signature mismatch: + Modules do not match: + sig val f : (< m : 'b. 'b * ('b * 'a) > as 'a) -> unit end + is not included in + sig + val f : < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -> unit + end + Values do not match: + val f : (< m : 'b. 'b * ('b * 'a) > as 'a) -> unit + is not included in + val f : < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -> unit # Characters 78-132: -Signature mismatch: -Modules do not match: - sig type t = < m : 'b. 'b * ('b * 'a) > as 'a end -is not included in - sig type t = < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > end -Type declarations do not match: - type t = < m : 'b. 'b * ('b * 'a) > as 'a -is not included in - type t = < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > +Error: Signature mismatch: + Modules do not match: + sig type t = < m : 'b. 'b * ('b * 'a) > as 'a end + is not included in + sig type t = < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > end + Type declarations do not match: + type t = < m : 'b. 'b * ('b * 'a) > as 'a + is not included in + type t = < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > # module M : sig type 'a t type u = < m : 'a. 'a t > end # module M : sig type 'a t val f : < m : 'a. 'a t > -> int end # module M : sig type 'a t val f : < m : 'a. 'a t > -> int end @@ -402,34 +407,36 @@ is not included in # type u = private [< t ] # - : u -> v = <fun> # Characters 9-21: -Type v = [> `A | `B ] is not a subtype of type u = [< `A | `B ] +Error: Type v = [> `A | `B ] is not a subtype of type u = [< `A | `B ] # type v = private [< t ] # Characters 9-21: -Type u = [< `A | `B ] is not a subtype of type v = [< `A | `B ] +Error: Type u = [< `A | `B ] is not a subtype of type v = [< `A | `B ] # type p = < x : p > # type q = private < x : p; .. > # - : q -> p = <fun> # Characters 9-21: -Type p = < x : p > is not a subtype of type q = < x : p; .. > +Error: Type p = < x : p > is not a subtype of type q = < x : p; .. > # Characters 14-100: -Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of type - < m : 'b. (< p : int; q : int; .. > as 'b) -> int > +Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > + is not a subtype of type + < m : 'b. (< p : int; q : int; .. > as 'b) -> int > # val f2 : < m : 'a. (< p : < a : int >; .. > as 'a) -> int > -> < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int > = <fun> # Characters 13-107: -Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int > -is not a subtype of type < m : 'a. (< p : < a : int >; .. > as 'a) -> int > +Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int > + is not a subtype of type + < m : 'a. (< p : < a : int >; .. > as 'a) -> int > # Characters 11-55: -Type < p : < a : int; b : int >; .. > is not a subtype of type - < p : < a : int >; .. > +Error: Type < p : < a : int; b : int >; .. > is not a subtype of type + < p : < a : int >; .. > The second object type has no method b # val f5 : < m : 'a. [< `A of < p : int > ] as 'a > -> < m : 'a. [< `A of < > ] as 'a > = <fun> # Characters 13-83: -Type < m : 'a. [< `A of < > ] as 'a > is not a subtype of type - < m : 'a. [< `A of < p : int > ] as 'a > +Error: Type < m : 'a. [< `A of < > ] as 'a > is not a subtype of type + < m : 'a. [< `A of < p : int > ] as 'a > # class c : object method id : 'a -> 'a end # type u = c option # val just : 'a option -> 'a = <fun> diff --git a/testlabl/poly.exp2 b/testlabl/poly.exp2 index 6a2405bd2d..5b31128736 100644 --- a/testlabl/poly.exp2 +++ b/testlabl/poly.exp2 @@ -1,4 +1,4 @@ - Objective Caml version 3.10.1+dev0 (2007-05-21) + Objective Caml version 3.11.0+beta1 # * * * # type 'a t = { t : 'a; } # type 'a fold = { fold : 'b. f:('b -> 'a -> 'b) -> init:'b -> 'b; } @@ -122,27 +122,27 @@ val c : circle = <obj> val d : float = 11.4536240470737098 # val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = <fun> # Characters 41-42: -This expression has type < m : 'a. 'a -> 'a list > but is here used with type - < m : 'a. 'a -> 'b > -The universal variable 'a would escape its scope +Error: This expression has type < m : 'a. 'a -> 'a list > + but is here used with type < m : 'a. 'a -> 'b > + The universal variable 'a would escape its scope # class id : object method id : 'a -> 'a end # class type id_spec = object method id : 'a -> 'a end # class id_impl : object method id : 'a -> 'a end # class a : object method m : bool end and b : object method id : 'a -> 'a end # Characters 72-77: -This method has type 'a -> 'a which is less general than 'b. 'b -> 'a +Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a # Characters 75-80: -This method has type 'a -> 'a which is less general than 'b. 'b -> 'a +Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'a # Characters 80-85: -This method has type 'a -> 'a which is less general than 'b. 'b -> 'b +Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'b # Characters 92-159: -This method has type 'a -> 'a which is less general than 'b. 'b -> 'b +Error: This method has type 'a -> 'a which is less general than 'b. 'b -> 'b # class c : object method m : 'a -> 'b -> 'a end # val f1 : id -> int * bool = <fun> # val f2 : id -> int * bool = <fun> # Characters 24-28: -This expression has type bool but is here used with type int +Error: This expression has type bool but is here used with type int # Characters 27-31: Warning X: this use of a polymorphic method is not principal. Characters 35-39: @@ -152,7 +152,7 @@ val f4 : id -> int * bool = <fun> # class id2 : object method id : 'a -> 'a method mono : int -> int end # val app : int * bool = (1, true) # Characters 4-25: -The type abbreviation foo is cyclic +Error: The type abbreviation foo is cyclic # class ['a] bar : 'a -> object end # type 'a foo = 'a foo bar # - : (< m : 'b. 'b * 'a > as 'a) -> 'c * (< m : 'e. 'e * 'd > as 'd) = <fun> @@ -222,13 +222,13 @@ class next : #numeral -> object method fold : ('a -> 'a) -> 'a -> 'a end # class node : object method as_variant : [> `Node of node_type ] end # type bad = { bad : 'a. 'a option ref; } # Characters 17-25: -This field value has type 'a option ref which is less general than - 'b. 'b option ref +Error: This field value has type 'a option ref which is less general than + 'b. 'b option ref # type bad2 = { mutable bad2 : 'a. 'a option ref option; } # val bad2 : bad2 = {bad2 = None} # Characters 13-28: -This field value has type 'a option ref option which is less general than - 'b. 'b option ref option +Error: This field value has type 'a option ref option + which is less general than 'b. 'b option ref option # val f : < m : 'a. < p : 'a * 'b > as 'b > -> 'c -> unit = <fun> # val f : < m : 'a. 'a * (< p : int * 'b > as 'b) > -> @@ -239,36 +239,36 @@ This field value has type 'a option ref option which is less general than # class c : object method m : ([> 'a t ] as 'a) -> 'a end # class c : object method m : ([> `A ] as 'a) option -> 'a end # Characters 145-166: -This type scheme cannot quantify 'a : +Error: This type scheme cannot quantify 'a : it escapes this scope. # type ('a, 'b) list_visitor = < caseCons : 'b -> 'b list -> 'a; caseNil : 'a > type 'a alist = < visit : 'b. ('b, 'a) list_visitor -> 'b > class type ct = object ('a) method fold : ('b -> 'a -> 'b) -> 'b -> 'b end type t = { f : 'a 'b. ('b -> (#ct as 'a) -> 'b) -> 'b; } # Characters 19-25: -The type abbreviation t is cyclic +Error: The type abbreviation t is cyclic # class ['a] a : object constraint 'a = [> `A of 'a a ] end type t = [ `A of t a ] # Characters 71-80: -Constraints are not satisfied in this type. +Error: Constraints are not satisfied in this type. Type ('a, 'b) t should be an instance of ('c, 'c) t # type 'a t = 'a and u = int t # type 'a t constraint 'a = int # Characters 26-32: -Constraints are not satisfied in this type. +Error: Constraints are not satisfied in this type. Type 'a u t should be an instance of int t # type 'a u = 'a constraint 'a = int and 'a v = 'a u t constraint 'a = int # type g = int # type 'a t = unit constraint 'a = g # Characters 26-32: -Constraints are not satisfied in this type. +Error: Constraints are not satisfied in this type. Type 'a u t should be an instance of g t # type 'a u = 'a constraint 'a = g and 'a v = 'a u t constraint 'a = int # Characters 38-58: -In the definition of v, type 'a list u should be 'a u +Error: In the definition of v, type 'a list u should be 'a u # type 'a t = 'a type 'a u = A of 'a t # type 'a t = < a : 'a > @@ -301,7 +301,7 @@ Characters 21-24: Warning U: this match case is unused. - : int * [< `B ] -> int = <fun> # Characters 69-135: -Constraints are not satisfied in this type. +Error: Constraints are not satisfied in this type. Type ([> `B of 'a ], 'a) b as 'a should be an instance of @@ -341,68 +341,73 @@ Warning X: the following private methods were made public implicitly: n. val f : unit -> < m : int; n : int > = <fun> # Characters 11-56: -This object is expected to have type c but has actually type - < m : int; n : 'a > -The first object type has no method n +Error: This object is expected to have type c but has actually type + < m : int; n : 'a > + The first object type has no method n # Characters 11-69: -This object is expected to have type < n : int > but has actually type - < m : 'a > -The second object type has no method n +Error: This object is expected to have type < n : int > but has actually type + < m : 'a > + The second object type has no method n # Characters 66-124: -This object is expected to have type < x : int; .. > but has actually type - < x : int > -Self type cannot be unified with a closed object type +Error: This object is expected to have type < x : int; .. > + but has actually type < x : int > + Self type cannot be unified with a closed object type # val o : < x : int > = <obj> # Characters 76-77: -This expression has type < m : 'b. 'b * < m : 'b * 'a > > as 'a -but is here used with type - < m : 'b. 'b * (< m : 'b * < m : 'd. 'd * 'c > > as 'c) > -Types for method m are incompatible +Error: This expression has type < m : 'b. 'b * < m : 'b * 'a > > as 'a + but is here used with type + < m : 'b. 'b * (< m : 'b * < m : 'd. 'd * 'c > > as 'c) > + Types for method m are incompatible # Characters 176-177: -This expression has type foo' = < m : 'a. 'a * 'a foo > -but is here used with type bar' = < m : 'a. 'a * 'a bar > -Type 'a foo = < m : 'a * 'a foo > is not compatible with type - 'a bar = < m : 'a * < m : 'b. 'b * 'a bar > > -Type 'a foo = < m : 'a * 'a foo > is not compatible with type - < m : 'b. 'b * 'a bar > -Types for method m are incompatible +Error: This expression has type foo' = < m : 'a. 'a * 'a foo > + but is here used with type bar' = < m : 'a. 'a * 'a bar > + Type 'a foo = < m : 'a * 'a foo > is not compatible with type + 'a bar = < m : 'a * < m : 'b. 'b * 'a bar > > + Type 'a foo = < m : 'a * 'a foo > is not compatible with type + < m : 'b. 'b * 'a bar > + Types for method m are incompatible # Characters 67-68: -This expression has type < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -but is here used with type - < m : 'a. 'a * ('a * < m : 'c. 'c * ('c * 'd) >) > as 'd -Types for method m are incompatible +Error: This expression has type + < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > + but is here used with type + < m : 'a. 'a * ('a * < m : 'c. 'c * ('c * 'd) >) > as 'd + Types for method m are incompatible # Characters 66-67: -This expression has type < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -but is here used with type - < m : 'a. 'a * ('a * < m : 'c. 'c * ('a * 'd) >) > as 'd -Types for method m are incompatible +Error: This expression has type + < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > + but is here used with type + < m : 'a. 'a * ('a * < m : 'c. 'c * ('a * 'd) >) > as 'd + Types for method m are incompatible # Characters 51-52: -This expression has type < m : 'b. 'b * ('b * 'a) > as 'a -but is here used with type < m : 'b. 'b * ('b * < m : 'd. 'd * 'c > as 'c) > -Types for method m are incompatible +Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a + but is here used with type + < m : 'b. 'b * ('b * < m : 'd. 'd * 'c > as 'c) > + Types for method m are incompatible # Characters 14-115: -Type < m : 'a. 'a -> ('a * (< m : 'd. 'd -> 'b as 'e > as 'c) as 'b) > -is not a subtype of type < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f +Error: Type < m : 'a. 'a -> ('a * (< m : 'd. 'd -> 'b as 'e > as 'c) as 'b) > + is not a subtype of type < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f # Characters 88-150: -Signature mismatch: -Modules do not match: - sig val f : (< m : 'b. 'b * ('b * 'a) > as 'a) -> unit end -is not included in - sig val f : < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -> unit end -Values do not match: - val f : (< m : 'b. 'b * ('b * 'a) > as 'a) -> unit -is not included in - val f : < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -> unit +Error: Signature mismatch: + Modules do not match: + sig val f : (< m : 'b. 'b * ('b * 'a) > as 'a) -> unit end + is not included in + sig + val f : < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -> unit + end + Values do not match: + val f : (< m : 'b. 'b * ('b * 'a) > as 'a) -> unit + is not included in + val f : < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > -> unit # Characters 78-132: -Signature mismatch: -Modules do not match: - sig type t = < m : 'b. 'b * ('b * 'a) > as 'a end -is not included in - sig type t = < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > end -Type declarations do not match: - type t = < m : 'b. 'b * ('b * 'a) > as 'a -is not included in - type t = < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > +Error: Signature mismatch: + Modules do not match: + sig type t = < m : 'b. 'b * ('b * 'a) > as 'a end + is not included in + sig type t = < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > end + Type declarations do not match: + type t = < m : 'b. 'b * ('b * 'a) > as 'a + is not included in + type t = < m : 'a. 'a * ('a * < m : 'c. 'c * 'b > as 'b) > # module M : sig type 'a t type u = < m : 'a. 'a t > end # module M : sig type 'a t val f : < m : 'a. 'a t > -> int end # module M : sig type 'a t val f : < m : 'a. 'a t > -> int end @@ -415,34 +420,36 @@ is not included in # type u = private [< t ] # - : u -> v = <fun> # Characters 9-21: -Type v = [> `A | `B ] is not a subtype of type u = [< `A | `B ] +Error: Type v = [> `A | `B ] is not a subtype of type u = [< `A | `B ] # type v = private [< t ] # Characters 9-21: -Type u = [< `A | `B ] is not a subtype of type v = [< `A | `B ] +Error: Type u = [< `A | `B ] is not a subtype of type v = [< `A | `B ] # type p = < x : p > # type q = private < x : p; .. > # - : q -> p = <fun> # Characters 9-21: -Type p = < x : p > is not a subtype of type q = < x : p; .. > +Error: Type p = < x : p > is not a subtype of type q = < x : p; .. > # Characters 14-100: -Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of type - < m : 'b. (< p : int; q : int; .. > as 'b) -> int > +Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > + is not a subtype of type + < m : 'b. (< p : int; q : int; .. > as 'b) -> int > # val f2 : < m : 'a. (< p : < a : int >; .. > as 'a) -> int > -> < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int > = <fun> # Characters 13-107: -Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int > -is not a subtype of type < m : 'a. (< p : < a : int >; .. > as 'a) -> int > +Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int > + is not a subtype of type + < m : 'a. (< p : < a : int >; .. > as 'a) -> int > # Characters 11-55: -Type < p : < a : int; b : int >; .. > is not a subtype of type - < p : < a : int >; .. > +Error: Type < p : < a : int; b : int >; .. > is not a subtype of type + < p : < a : int >; .. > The second object type has no method b # val f5 : < m : 'a. [< `A of < p : int > ] as 'a > -> < m : 'a. [< `A of < > ] as 'a > = <fun> # Characters 13-83: -Type < m : 'a. [< `A of < > ] as 'a > is not a subtype of type - < m : 'a. [< `A of < p : int > ] as 'a > +Error: Type < m : 'a. [< `A of < > ] as 'a > is not a subtype of type + < m : 'a. [< `A of < p : int > ] as 'a > # class c : object method id : 'a -> 'a end # type u = c option # val just : 'a option -> 'a = <fun> diff --git a/testlabl/private.ml b/testlabl/private.ml new file mode 100644 index 0000000000..f865163e28 --- /dev/null +++ b/testlabl/private.ml @@ -0,0 +1,31 @@ +module Foobar : sig + type t = private int +end = struct + type t = int +end;; + +module F0 : sig type t = private int end = Foobar;; + +let f (x : F0.t) = (x : Foobar.t);; (* fails *) + +module F = Foobar;; + +let f (x : F.t) = (x : Foobar.t);; + +module M = struct type t = <m:int> end;; +module M1 : sig type t = private <m:int; ..> end = M;; +module M2 : sig type t = private <m:int; ..> end = M1;; +fun (x : M1.t) -> (x : M2.t);; (* fails *) + +module M3 : sig type t = private M1.t end = M1;; +fun x -> (x : M3.t :> M1.t);; +fun x -> (x : M3.t :> M.t);; +module M4 : sig type t = private M3.t end = M2;; (* fails *) +module M4 : sig type t = private M3.t end = M;; (* fails *) +module M4 : sig type t = private M3.t end = M1;; (* might be ok *) +module M5 : sig type t = private M1.t end = M3;; +module M6 : sig type t = private < n:int; .. > end = M1;; (* fails *) + +module Bar : sig type t = private Foobar.t val f : int -> t end = + struct type t = int let f (x : int) = (x : t) end;; (* must fail *) + 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/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/topdirs.ml b/toplevel/topdirs.ml index d8a7765055..9e542f4529 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.mli b/typing/ctype.mli index 87d43aa463..7fa6a2bcae 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -131,6 +131,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. *) 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/typemod.ml b/typing/typemod.ml index d931a16927..ef8c947e51 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -503,7 +503,7 @@ let check_recmodule_inclusion env bindings = module rec X : DECL = MOD where MOD has inferred type ACTUAL The "natural" typing condition E, X: ACTUAL |- ACTUAL <: DECL - leads to circularities through manifest types. + leads to circularities through manifest types. Instead, we "unroll away" the potential circularities a finite number of times. The (weaker) condition we implement is: E, X: DECL, diff --git a/utils/ccomp.ml b/utils/ccomp.ml index 3cb192e318..fbbbdf10b3 100644 --- a/utils/ccomp.ml +++ b/utils/ccomp.ml @@ -24,7 +24,7 @@ let command cmdline = let run_command cmdline = ignore(command cmdline) -(* Build @responsefile to work around Windows limitations on +(* Build @responsefile to work around Windows limitations on command-line length *) let build_diversion lst = let (responsefile, oc) = Filename.open_temp_file "camlresp" "" in @@ -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 94494dac4a..38445235cf 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -46,7 +46,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 *) @@ -90,4 +90,3 @@ let std_include_dir () = let shared = ref false (* -shared *) let dlcode = ref true (* not -nodynlink *) - diff --git a/utils/clflags.mli b/utils/clflags.mli index 8ba36210e1..af4ded9a6e 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -43,7 +43,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 |