Commits

Anonymous committed a45ed2c

merge changes from 3.12.0 to 3.12.1

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@11123f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

Comments (0)

Files changed (253)

 bytecomp/typeopt.cmi: typing/typedtree.cmi typing/path.cmi \
     bytecomp/lambda.cmi
 bytecomp/bytegen.cmo: typing/types.cmi bytecomp/switch.cmi typing/subst.cmi \
-    typing/stypes.cmi typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \
+    typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \
     bytecomp/instruct.cmi typing/ident.cmi utils/config.cmi \
-    parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi
+    parsing/asttypes.cmi bytecomp/bytegen.cmi
 bytecomp/bytegen.cmx: typing/types.cmx bytecomp/switch.cmx typing/subst.cmx \
-    typing/stypes.cmx typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx \
+    typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx \
     bytecomp/instruct.cmx typing/ident.cmx utils/config.cmx \
-    parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi
+    parsing/asttypes.cmi bytecomp/bytegen.cmi
 bytecomp/bytelibrarian.cmo: utils/misc.cmi utils/config.cmi \
     bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytelink.cmi \
     bytecomp/bytelibrarian.cmi
     parsing/asttypes.cmi bytecomp/printlambda.cmi
 bytecomp/runtimedef.cmo: bytecomp/runtimedef.cmi
 bytecomp/runtimedef.cmx: bytecomp/runtimedef.cmi
-bytecomp/simplif.cmo: bytecomp/lambda.cmi typing/ident.cmi utils/clflags.cmi \
-    parsing/asttypes.cmi bytecomp/simplif.cmi
-bytecomp/simplif.cmx: bytecomp/lambda.cmx typing/ident.cmx utils/clflags.cmx \
-    parsing/asttypes.cmi bytecomp/simplif.cmi
+bytecomp/simplif.cmo: typing/stypes.cmi bytecomp/lambda.cmi typing/ident.cmi \
+    utils/clflags.cmi parsing/asttypes.cmi typing/annot.cmi \
+    bytecomp/simplif.cmi
+bytecomp/simplif.cmx: typing/stypes.cmx bytecomp/lambda.cmx typing/ident.cmx \
+    utils/clflags.cmx parsing/asttypes.cmi typing/annot.cmi \
+    bytecomp/simplif.cmi
 bytecomp/switch.cmo: bytecomp/switch.cmi
 bytecomp/switch.cmx: bytecomp/switch.cmi
 bytecomp/symtable.cmo: utils/tbl.cmi bytecomp/runtimedef.cmi \
 asmcomp/coloring.cmo: asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/coloring.cmi
 asmcomp/coloring.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/coloring.cmi
 asmcomp/comballoc.cmo: asmcomp/reg.cmi asmcomp/mach.cmi utils/config.cmi \
-    asmcomp/comballoc.cmi
+    asmcomp/arch.cmo asmcomp/comballoc.cmi
 asmcomp/comballoc.cmx: asmcomp/reg.cmx asmcomp/mach.cmx utils/config.cmx \
-    asmcomp/comballoc.cmi
+    asmcomp/arch.cmx asmcomp/comballoc.cmi
 asmcomp/compilenv.cmo: utils/misc.cmi typing/ident.cmi typing/env.cmi \
     utils/config.cmi asmcomp/cmx_format.cmi asmcomp/clambda.cmi \
     asmcomp/compilenv.cmi
     asmcomp/schedgen.cmi
 asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/scheduling.cmi
 asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/scheduling.cmi
-asmcomp/selectgen.cmo: utils/tbl.cmi asmcomp/reg.cmi asmcomp/proc.cmi \
-    utils/misc.cmi asmcomp/mach.cmi typing/ident.cmi asmcomp/debuginfo.cmi \
-    asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/selectgen.cmi
-asmcomp/selectgen.cmx: utils/tbl.cmx asmcomp/reg.cmx asmcomp/proc.cmx \
-    utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx asmcomp/debuginfo.cmx \
-    asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/selectgen.cmi
+asmcomp/selectgen.cmo: utils/tbl.cmi bytecomp/simplif.cmi asmcomp/reg.cmi \
+    asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi typing/ident.cmi \
+    asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \
+    asmcomp/selectgen.cmi
+asmcomp/selectgen.cmx: utils/tbl.cmx bytecomp/simplif.cmx asmcomp/reg.cmx \
+    asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx \
+    asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \
+    asmcomp/selectgen.cmi
 asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi asmcomp/proc.cmi \
     utils/misc.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \
     utils/clflags.cmi asmcomp/arch.cmo asmcomp/selection.cmi
 Bug Fixes:
 
 
+Objective Caml 3.12.1:
+----------------------
+
+Bug fixes:
+- PR#4345, PR#4767: problems with camlp4 printing of float values
+- PR#4380: ocamlbuild should not use tput on windows
+- PR#4487, PR#5164: multiple 'module type of' are incompatible
+- PR#4552: ocamlbuild does not create symlinks when using '.itarget' file
+- PR#4673, PR#5144: camlp4 fails on object copy syntax
+- PR#4702: system threads: cleanup tick thread at exit
+- PR#4732: camlp4 rejects polymorphic variants using keywords from macros
+- PR#4778: Win32/MSVC port: rare syntax error in generated MASM assembly file
+- PR#4794, PR#4959: call annotations not generated by ocamlopt
+- PR#4820: revised syntax pretty printer crashes with 'Stack_overflow'
+- PR#4928: wrong printing of classes and class types by camlp4
+- PR#4939: camlp4 rejects patterns of the '?x:_' form
+- PR#4967: ocamlbuild passes wrong switches to ocamldep through menhir
+- PR#4972: mkcamlp4 does not include 'dynlink.cma'
+- PR#5039: ocamlbuild should use '-linkpkg' only when linking programs
+- PR#5066: ocamldoc: add -charset option used in html generator
+- PR#5069: fcntl() in caml_sys_open may block, do it within blocking section
+- PR#5071, PR#5129, PR#5134: inconsistencies between camlp4 and camlp4* binaries
+- PR#5080, PR#5104: regression in type constructor handling by camlp4
+- PR#5090: bad interaction between toplevel and camlp4
+- PR#5095: ocamlbuild ignores some tags when building bytecode objects
+- PR#5100: ocamlbuild always rebuilds a 'cmxs' file
+- PR#5103: build and install objinfo when building with ocamlbuild
+- PR#5109: crash when a parser calls a lexer that calls another parser
+- PR#5110: invalid module name when using optional argument
+- PR#5115: bytecode executables produced by msvc64 port crash on 32-bit versions
+- PR#5117: bigarray: wrong function name without HAS_MMAP; missing include
+- PR#5118: Camlp4o and integer literals
+- PR#5122: camlp4 rejects lowercase identifiers for module types
+- PR#5123: shift_right_big_int returns a wrong zero
+- PR#5124: substitution inside a signature leads to odd printing
+- PR#5128: typo in 'Camlp4ListComprehension' syntax extension
+- PR#5136: obsolete function used in emacs mode
+- PR#5145: ocamldoc: missing html escapes
+- PR#5146: problem with spaces in multi-line string constants
+- PR#5149: (partial) various documentation problems
+- PR#5156: rare compiler crash with objects
+- PR#5165: ocamlbuild does not pass '-thread' option to ocamlfind
+- PR#5167: camlp4r loops when printing package type
+- PR#5172: camlp4 support for 'module type of' construct
+- PR#5175: in bigarray accesses, make sure bigarray expr is evaluated only once
+- PR#5177: Gc.compact implies Gc.full_major
+- PR#5182: use bytecode version of ocamldoc to generate man pages
+- PR#5184: under Windows, alignment issue with bigarrays mapped from files
+- PR#5188: double-free corruption in bytecode system threads
+- PR#5192: mismatch between words and bytes in interpreting max_young_wosize
+- PR#5202: error in documentation of atan2
+- PR#5209: natdynlink incorrectly detected on BSD systems
+- PR#5213: ocamlbuild should pass '-rectypes' to ocamldoc when needed
+- PR#5217: ocamlfind plugin should add '-linkpkg' for toplevel
+- PR#5228: document the exceptions raised by functions in 'Filename'
+- PR#5229: typo in build script ('TAG_LINE' vs 'TAGLINE')
+- PR#5230: error in documentation of Scanf.Scanning.open_in
+- PR#5234: option -shared reverses order of -cclib options
+- PR#5237: incorrect .size directives generated for x86-32 and x86-64
+- PR#5244: String.compare uses polymorphic compare_val (regression of PR#4194)
+- PR#5248: regression introduced while fixing PR#5118
+- PR#5252: typo in docs
+- PR#5258: win32unix: unix fd leak under windows
+- PR#5269: (tentative fix) Wrong ext_ref entries in .annot files
+- PR#5272: caml.el doesn't recognize downto as a keyword
+- PR#5276: issue with ocamlc -pack and recursively-packed modules
+- PR#5280: alignment constraints incorrectly autodetected on MIPS 32
+- PR#5281: typo in error message
+- PR#5308: unused variables not detected in "include (struct .. end)"
+- camlp4 revised syntax printing bug in the toplevel (reported on caml-list)
+- configure: do not define _WIN32 under cygwin
+- Hardened generic comparison in the case where two custom blocks
+  are compared and have different sets of custom operations.
+- Hardened comparison between bigarrays in the case where the two
+  bigarrays have different kinds.
+- Fixed wrong autodetection of expm1() and log1p().
+- don't add .exe suffix when installing the ocamlmktop shell script
+- ocamldoc: minor fixes related to the display of ocamldoc options
+- fixed bug with huge values in OCAMLRUNPARAM
+- mismatch between declaration and definition of caml_major_collection_slice
+
+Feature wishes:
+- PR#4992: added '-ml-synonym' and '-mli-synonym' options to ocamldep
+- PR#5065: added '-ocamldoc' option to ocamlbuild
+- PR#5139: added possibility to add options to ocamlbuild
+- PR#5158: added access to current camlp4 parsers and printers
+- PR#5180: improved instruction selection for float operations on amd64
+- stdlib: added a 'usage_string' function to Arg
+- allow with constraints to add a type equation to a datatype definition
+- ocamldoc: allow to merge '@before' tags like other ones
+- ocamlbuild: allow dependency on file "_oasis"
+
+Other changes:
+- Changed default minor heap size from 32k to 256k words.
+- Added new operation 'compare_ext' to custom blocks, called when
+  comparing a custom block value with an unboxed integer.
+
+
 Objective Caml 3.12.0:
 ----------------------
 
         umask 022       # make sure to give read & execute permission to all
         make install
 
-      In the ocamlbuild setting instead of make install do:
-
-        ./build/install.sh
-
 7- Installation is complete. Time to clean up. From the toplevel
 directory, do "make clean".
 
 and "the Compiler" refers to all files marked "Copyright INRIA" in the
 following directories and their sub-directories:
 
-  asmcomp, boot, bytecomp, debugger, driver, lex, ocamldoc, parsing,
-  tools, toplevel, typing, utils, yacc
+  asmcomp, boot, build, bytecomp, debugger, driver, lex, man,
+  ocamlbuild, ocamldoc, parsing, testsuite, tools, toplevel, typing,
+  utils, yacc
 
 The Compiler is distributed under the terms of the Q Public License
 version 1.0 with a change to choice of law (included below).
 
 Tier 1 (actively used and maintained by the core Caml team):
 
-    AMD64 (Opteron)    Linux
+    AMD64 (Opteron)    Linux, MacOS X, MS Windows
     IA32 (Pentium)     Linux, FreeBSD, MacOS X, MS Windows
     PowerPC            MacOS X
 
 that is compatible with the GPL.  Executables generated by MSVC or by
 MinGW have no such restrictions.
 
-(**) The debugger is supported but the "replay" function of it are not enabled.
+(**) The debugger is supported but the "replay" functions are not enabled.
 Other functions are available (step, goto, run...).
 
 The remainder of this document gives more information on each port.
            The native Win32 port built with Mingw
            --------------------------------------
 
+NOTE: Due to changes in cygwin's compilers, this port is not available
+in OCaml 3.12.1.  A patch will be made available soon after the release
+of 3.12.1.
+
 REQUIREMENTS:
 
 This port runs under MS Windows Vista, XP, and 2000.
 - Windows NT, 2000, XP, or Vista.
 - Cygwin: http://sourceware.cygnus.com/cygwin/
   Install at least the following packages: binutils, diffutils,
-    gcc-core, gcc-mingw-core, make, mingw-runtime, ncurses, w32-api.
+    gcc-core, gcc-mingw-core, make, mingw-runtime, ncurses, w32api.
 - TCL/TK version 8.5 (see above).
 - The flexdll tool (see above).
 
 
 The libraries available in this port are "num", "str", "threads",
 "unix" and "labltk".  "graph" is not available.
-The replay debugger is supported.
+The replay debugger is fully supported.
+When upgrading from 3.12.0 to 3.12.1, you will need to remove
+/usr/local/bin/ocamlmktop.exe before typing "make install".
 
 ------------------------------------------------------------------------------
 
-3.13.0+dev4 (2011-06-20)
+3.13.0+dev5 (2011-07-20)
 
 # The version string is the first line of this file.
 # It must be in the format described in stdlib/sys.mli

asmcomp/amd64/emit.mlp

     | Lop(Imove | Ispill | Ireload) ->
         let src = i.arg.(0) and dst = i.res.(0) in
         if src.loc <> dst.loc then begin
-          if src.typ = Float then
-            `	movsd	{emit_reg src}, {emit_reg dst}\n`
-          else
+          match src.typ, src.loc, dst.loc with
+            Float, Reg _, Reg _ ->
+              `	movapd	{emit_reg src}, {emit_reg dst}\n`
+          | Float, _, _ ->
+              `	movsd	{emit_reg src}, {emit_reg dst}\n`
+          | _ ->
               `	movq	{emit_reg src}, {emit_reg dst}\n`
         end
     | Lop(Iconst_int n) ->
         | _ ->
           let lbl = new_label() in
           float_constants := (lbl, s) :: !float_constants;
-          `	movlpd	{emit_label lbl}(%rip), {emit_reg i.res.(0)}\n`
+          `	movsd	{emit_label lbl}(%rip), {emit_reg i.res.(0)}\n`
         end
     | Lop(Iconst_symbol s) ->
         `	{load_symbol_addr s}, {emit_reg i.res.(0)}\n`
           | Single ->
             `	cvtss2sd {emit_addressing addr i.arg 0}, {emit_reg dest}\n`
           | Double | Double_u ->
-            `	movlpd	{emit_addressing addr i.arg 0}, {emit_reg dest}\n`
+            `	movsd	{emit_addressing addr i.arg 0}, {emit_reg dest}\n`
         end
     | Lop(Istore(chunk, addr)) ->
         begin match chunk with
             `	cvtsd2ss {emit_reg i.arg.(0)}, %xmm15\n`;
             `	movss	%xmm15, {emit_addressing addr i.arg 1}\n`
           | Double | Double_u ->
-            `	movlpd	{emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n`
+            `	movsd	{emit_reg i.arg.(0)}, {emit_addressing addr i.arg 1}\n`
         end
     | Lop(Ialloc n) ->
         if !fastcode_flag then begin

asmcomp/amd64/emit_nt.mlp

     | Lop(Imove | Ispill | Ireload) ->
         let src = i.arg.(0) and dst = i.res.(0) in
         if src.loc <> dst.loc then begin
-          if src.typ = Float then
-            `	movsd	{emit_reg dst}, {emit_reg src}\n`
-          else
-            `	mov	{emit_reg dst}, {emit_reg src}\n`
+          match src.typ, src.loc, dst.loc with
+            Float, Reg _, Reg _ ->
+              `	movapd	{emit_reg dst}, {emit_reg src}\n`
+          | Float, _, _ ->
+              `	movsd	{emit_reg dst}, {emit_reg src}\n`
+          | _ ->
+              `	mov	{emit_reg dst}, {emit_reg src}\n`
         end
     | Lop(Iconst_int n) ->
         if n = 0n then begin
         | _ ->
           let lbl = new_label() in
           float_constants := (lbl, s) :: !float_constants;
-          `	movlpd	{emit_reg i.res.(0)}, {emit_label lbl}\n`
+          `	movsd	{emit_reg i.res.(0)}, {emit_label lbl}\n`
         end
     | Lop(Iconst_symbol s) ->
         add_used_symbol s;
           | Single ->
             `	cvtss2sd {emit_reg dest}, REAL4 PTR {emit_addressing addr i.arg 0}\n`
           | Double | Double_u ->
-            `	movlpd	{emit_reg dest}, REAL8 PTR {emit_addressing addr i.arg 0}\n`
+            `	movsd	{emit_reg dest}, REAL8 PTR {emit_addressing addr i.arg 0}\n`
         end
     | Lop(Istore(chunk, addr)) ->
         begin match chunk with
             `	cvtsd2ss xmm15, {emit_reg i.arg.(0)}\n`;
             `	movss	REAL4 PTR {emit_addressing addr i.arg 1}, xmm15\n`
           | Double | Double_u ->
-            `	movlpd	REAL8 PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n`
+            `	movsd	REAL8 PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n`
         end
     | Lop(Ialloc n) ->
         if !fastcode_flag then begin

asmcomp/asmlink.ml

   Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs;
   Clflags.ccopts := !lib_ccopts @ !Clflags.ccopts;
   let objfiles = List.rev (List.map object_file_name objfiles) @
-    !Clflags.ccobjs in
+    (List.rev !Clflags.ccobjs) in
 
   let startup =
     if !Clflags.keep_startup_file

asmcomp/closure.ml

       | ((ufunct, _), uargs) ->
           (Ugeneric_apply(ufunct, uargs, Debuginfo.none), Value_unknown)
       end
-  | Lsend(kind, met, obj, args) ->
+  | Lsend(kind, met, obj, args, _) ->
       let (umet, _) = close fenv cenv met in
       let (uobj, _) = close fenv cenv obj in
       (Usend(kind, umet, uobj, close_list fenv cenv args, Debuginfo.none),

asmcomp/cmmgen.ml

   | Pbigarray_complex64 -> Double
 
 let bigarray_get unsafe elt_kind layout b args dbg =
-  match elt_kind with
-    Pbigarray_complex32 | Pbigarray_complex64 ->
-      let kind = bigarray_word_kind elt_kind in
-      let sz = bigarray_elt_size elt_kind / 2 in
-      bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
-        box_complex
-          (Cop(Cload kind, [addr]))
-          (Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])])))
-  | _ ->
-      Cop(Cload (bigarray_word_kind elt_kind),
-          [bigarray_indexing unsafe elt_kind layout b args dbg])
+  bind "ba" b (fun b ->
+    match elt_kind with
+      Pbigarray_complex32 | Pbigarray_complex64 ->
+        let kind = bigarray_word_kind elt_kind in
+        let sz = bigarray_elt_size elt_kind / 2 in
+        bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
+          box_complex
+            (Cop(Cload kind, [addr]))
+            (Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])])))
+    | _ ->
+        Cop(Cload (bigarray_word_kind elt_kind),
+            [bigarray_indexing unsafe elt_kind layout b args dbg]))
 
 let bigarray_set unsafe elt_kind layout b args newval dbg =
-  match elt_kind with
-    Pbigarray_complex32 | Pbigarray_complex64 ->
-      let kind = bigarray_word_kind elt_kind in
-      let sz = bigarray_elt_size elt_kind / 2 in
-      bind "newval" newval (fun newv ->
-      bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
-        Csequence(
-          Cop(Cstore kind, [addr; complex_re newv]),
-          Cop(Cstore kind,
-              [Cop(Cadda, [addr; Cconst_int sz]); complex_im newv]))))
-  | _ ->
-      Cop(Cstore (bigarray_word_kind elt_kind),
-          [bigarray_indexing unsafe elt_kind layout b args dbg; newval])
+  bind "ba" b (fun b ->
+    match elt_kind with
+      Pbigarray_complex32 | Pbigarray_complex64 ->
+        let kind = bigarray_word_kind elt_kind in
+        let sz = bigarray_elt_size elt_kind / 2 in
+        bind "newval" newval (fun newv ->
+        bind "addr" (bigarray_indexing unsafe elt_kind layout b args dbg) (fun addr ->
+          Csequence(
+            Cop(Cstore kind, [addr; complex_re newv]),
+            Cop(Cstore kind,
+                [Cop(Cadda, [addr; Cconst_int sz]); complex_im newv]))))
+    | _ ->
+        Cop(Cstore (bigarray_word_kind elt_kind),
+            [bigarray_indexing unsafe elt_kind layout b args dbg; newval]))
 
 (* Simplification of some primitives into C calls *)
 

asmcomp/comballoc.ml

             combine i.next (Pending_alloc(i.res.(0), sz)) in
           (instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, 0)
       | Pending_alloc(reg, ofs) ->
-          if ofs + sz < Config.max_young_wosize then begin
+          if ofs + sz < Config.max_young_wosize * Arch.size_addr then begin
             let (newnext, newsz) =
               combine i.next (Pending_alloc(reg, ofs + sz)) in
             (instr_cons (Iop(Iintop_imm(Iadd, ofs))) [| reg |] i.res newnext,

asmcomp/i386/emit_nt.mlp

       add_def_symbol s ;
       `{emit_symbol s} LABEL DWORD\n`
   | Cdefine_label lbl ->
-      `{emit_label (100000 + lbl)} `
+      `{emit_label (100000 + lbl)}	LABEL DWORD\n`
   | Cint8 n ->
       `	BYTE	{emit_int n}\n`
   | Cint16 n ->

asmcomp/selectgen.ml

     fun_fast = f.Cmm.fun_fast }
 
 end
+
+(* Tail call criterion (estimated).  Assumes:
+- all arguments are of type "int" (always the case for Caml function calls)
+- one extra argument representing the closure environment (conservative).
+*)
+
+let is_tail_call nargs =
+  assert (Reg.dummy.typ = Int);
+  let args = Array.make (nargs + 1) Reg.dummy in
+  let (loc_arg, stack_ofs) = Proc.loc_arguments args in
+  stack_ofs = 0
+
+let _ =
+  Simplif.is_tail_native_heuristic := is_tail_call
 	STORE_VAR(%r14, caml_exception_pointer)
     /* Save floating-point registers */
         subq    $(16*8), %rsp
-        movlpd  %xmm0, 0*8(%rsp)
-        movlpd  %xmm1, 1*8(%rsp)
-        movlpd  %xmm2, 2*8(%rsp)
-        movlpd  %xmm3, 3*8(%rsp)
-        movlpd  %xmm4, 4*8(%rsp)
-        movlpd  %xmm5, 5*8(%rsp)
-        movlpd  %xmm6, 6*8(%rsp)
-        movlpd  %xmm7, 7*8(%rsp)
-        movlpd  %xmm8, 8*8(%rsp)
-        movlpd  %xmm9, 9*8(%rsp)
-        movlpd  %xmm10, 10*8(%rsp)
-        movlpd  %xmm11, 11*8(%rsp)
-        movlpd  %xmm12, 12*8(%rsp)
-        movlpd  %xmm13, 13*8(%rsp)
-        movlpd  %xmm14, 14*8(%rsp)
-        movlpd  %xmm15, 15*8(%rsp)
+        movsd   %xmm0, 0*8(%rsp)
+        movsd   %xmm1, 1*8(%rsp)
+        movsd   %xmm2, 2*8(%rsp)
+        movsd   %xmm3, 3*8(%rsp)
+        movsd   %xmm4, 4*8(%rsp)
+        movsd   %xmm5, 5*8(%rsp)
+        movsd   %xmm6, 6*8(%rsp)
+        movsd   %xmm7, 7*8(%rsp)
+        movsd   %xmm8, 8*8(%rsp)
+        movsd   %xmm9, 9*8(%rsp)
+        movsd   %xmm10, 10*8(%rsp)
+        movsd   %xmm11, 11*8(%rsp)
+        movsd   %xmm12, 12*8(%rsp)
+        movsd   %xmm13, 13*8(%rsp)
+        movsd   %xmm14, 14*8(%rsp)
+        movsd   %xmm15, 15*8(%rsp)
     /* Call the garbage collector */
         call    GCALL(caml_garbage_collection)
     /* Restore caml_young_ptr, caml_exception_pointer */
 	LOAD_VAR(caml_young_ptr, %r15)
 	LOAD_VAR(caml_exception_pointer, %r14)
     /* Restore all regs used by the code generator */
-        movlpd  0*8(%rsp), %xmm0
-        movlpd  1*8(%rsp), %xmm1
-        movlpd  2*8(%rsp), %xmm2
-        movlpd  3*8(%rsp), %xmm3
-        movlpd  4*8(%rsp), %xmm4
-        movlpd  5*8(%rsp), %xmm5
-        movlpd  6*8(%rsp), %xmm6
-        movlpd  7*8(%rsp), %xmm7
-        movlpd  8*8(%rsp), %xmm8
-        movlpd  9*8(%rsp), %xmm9
-        movlpd  10*8(%rsp), %xmm10
-        movlpd  11*8(%rsp), %xmm11
-        movlpd  12*8(%rsp), %xmm12
-        movlpd  13*8(%rsp), %xmm13
-        movlpd  14*8(%rsp), %xmm14
-        movlpd  15*8(%rsp), %xmm15
+        movsd   0*8(%rsp), %xmm0
+        movsd   1*8(%rsp), %xmm1
+        movsd   2*8(%rsp), %xmm2
+        movsd   3*8(%rsp), %xmm3
+        movsd   4*8(%rsp), %xmm4
+        movsd   5*8(%rsp), %xmm5
+        movsd   6*8(%rsp), %xmm6
+        movsd   7*8(%rsp), %xmm7
+        movsd   8*8(%rsp), %xmm8
+        movsd   9*8(%rsp), %xmm9
+        movsd   10*8(%rsp), %xmm10
+        movsd   11*8(%rsp), %xmm11
+        movsd   12*8(%rsp), %xmm12
+        movsd   13*8(%rsp), %xmm13
+        movsd   14*8(%rsp), %xmm14
+        movsd   15*8(%rsp), %xmm15
         addq    $(16*8), %rsp
         popq    %rax
         popq    %rbx

asmrun/amd64nt.asm

         mov     caml_gc_regs, rsp
     ; Save floating-point registers
         sub     rsp, 16*8
-        movlpd  QWORD PTR [rsp + 0*8], xmm0
-        movlpd  QWORD PTR [rsp + 1*8], xmm1
-        movlpd  QWORD PTR [rsp + 2*8], xmm2
-        movlpd  QWORD PTR [rsp + 3*8], xmm3
-        movlpd  QWORD PTR [rsp + 4*8], xmm4
-        movlpd  QWORD PTR [rsp + 5*8], xmm5
-        movlpd  QWORD PTR [rsp + 6*8], xmm6
-        movlpd  QWORD PTR [rsp + 7*8], xmm7
-        movlpd  QWORD PTR [rsp + 8*8], xmm8
-        movlpd  QWORD PTR [rsp + 9*8], xmm9
-        movlpd  QWORD PTR [rsp + 10*8], xmm10
-        movlpd  QWORD PTR [rsp + 11*8], xmm11
-        movlpd  QWORD PTR [rsp + 12*8], xmm12
-        movlpd  QWORD PTR [rsp + 13*8], xmm13
-        movlpd  QWORD PTR [rsp + 14*8], xmm14
-        movlpd  QWORD PTR [rsp + 15*8], xmm15
+        movsd   QWORD PTR [rsp + 0*8], xmm0
+        movsd   QWORD PTR [rsp + 1*8], xmm1
+        movsd   QWORD PTR [rsp + 2*8], xmm2
+        movsd   QWORD PTR [rsp + 3*8], xmm3
+        movsd   QWORD PTR [rsp + 4*8], xmm4
+        movsd   QWORD PTR [rsp + 5*8], xmm5
+        movsd   QWORD PTR [rsp + 6*8], xmm6
+        movsd   QWORD PTR [rsp + 7*8], xmm7
+        movsd   QWORD PTR [rsp + 8*8], xmm8
+        movsd   QWORD PTR [rsp + 9*8], xmm9
+        movsd   QWORD PTR [rsp + 10*8], xmm10
+        movsd   QWORD PTR [rsp + 11*8], xmm11
+        movsd   QWORD PTR [rsp + 12*8], xmm12
+        movsd   QWORD PTR [rsp + 13*8], xmm13
+        movsd   QWORD PTR [rsp + 14*8], xmm14
+        movsd   QWORD PTR [rsp + 15*8], xmm15
     ; Call the garbage collector
         sub rsp, 32      ; PR#5008: bottom 32 bytes are reserved for callee
         call caml_garbage_collection
         add rsp, 32      ; PR#5008
     ; Restore all regs used by the code generator
-        movlpd  xmm0, QWORD PTR [rsp + 0*8]
-        movlpd  xmm1, QWORD PTR [rsp + 1*8]
-        movlpd  xmm2, QWORD PTR [rsp + 2*8]
-        movlpd  xmm3, QWORD PTR [rsp + 3*8]
-        movlpd  xmm4, QWORD PTR [rsp + 4*8]
-        movlpd  xmm5, QWORD PTR [rsp + 5*8]
-        movlpd  xmm6, QWORD PTR [rsp + 6*8]
-        movlpd  xmm7, QWORD PTR [rsp + 7*8]
-        movlpd  xmm8, QWORD PTR [rsp + 8*8]
-        movlpd  xmm9, QWORD PTR [rsp + 9*8]
-        movlpd  xmm10, QWORD PTR [rsp + 10*8]
-        movlpd  xmm11, QWORD PTR [rsp + 11*8]
-        movlpd  xmm12, QWORD PTR [rsp + 12*8]
-        movlpd  xmm13, QWORD PTR [rsp + 13*8]
-        movlpd  xmm14, QWORD PTR [rsp + 14*8]
-        movlpd  xmm15, QWORD PTR [rsp + 15*8]
+        movsd   xmm0, QWORD PTR [rsp + 0*8]
+        movsd   xmm1, QWORD PTR [rsp + 1*8]
+        movsd   xmm2, QWORD PTR [rsp + 2*8]
+        movsd   xmm3, QWORD PTR [rsp + 3*8]
+        movsd   xmm4, QWORD PTR [rsp + 4*8]
+        movsd   xmm5, QWORD PTR [rsp + 5*8]
+        movsd   xmm6, QWORD PTR [rsp + 6*8]
+        movsd   xmm7, QWORD PTR [rsp + 7*8]
+        movsd   xmm8, QWORD PTR [rsp + 8*8]
+        movsd   xmm9, QWORD PTR [rsp + 9*8]
+        movsd   xmm10, QWORD PTR [rsp + 10*8]
+        movsd   xmm11, QWORD PTR [rsp + 11*8]
+        movsd   xmm12, QWORD PTR [rsp + 12*8]
+        movsd   xmm13, QWORD PTR [rsp + 13*8]
+        movsd   xmm14, QWORD PTR [rsp + 14*8]
+        movsd   xmm15, QWORD PTR [rsp + 15*8]
         add     rsp, 16*8
         pop     rax
         pop     rbx

boot/ocamlc

Binary file modified.

boot/ocamldep

Binary file modified.

boot/ocamllex

Binary file modified.
 # $Id$
 cd `dirname $0`/..
 set -ex
-TAGLINE='true: -use_stdlib'
+TAG_LINE='true: -use_stdlib'
 ./boot/ocamlrun boot/myocamlbuild.boot \
   -tag-line "$TAG_LINE" \
   boot/stdlib.cma boot/std_exit.cmo

build/camlp4-bootstrap-recipe.txt

  Then "Generate Camlp4Ast.ml" and build.
 
  We get a single warning in Camlp4/Struct/Camlp4Ast2OCamlAst.ml but
- don't fix it now.
+ don't fix it now. Notice that you may need to disable '-warn-error'
+ in order to be able to successfully compile, despite of the warning.
 
  Then I hacked the camlp4/boot/camlp4boot.ml to generate:
    Ast.ExOpI(_loc, i, e)

build/camlp4-byte-only.sh

 #                                                                       #
 #   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.         #
+#   under the terms of the Q Public License version 1.0.                #
 #                                                                       #
 #########################################################################
 

build/camlp4-native-only.sh

 #                                                                       #
 #   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.         #
+#   under the terms of the Q Public License version 1.0.                #
 #                                                                       #
 #########################################################################
 

build/fastworld.sh

 #                                                                       #
 #   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.         #
+#   under the terms of the Q Public License version 1.0.                #
 #                                                                       #
 #########################################################################
 
   $OCAMLC_NATIVE $TOPLEVEL $OTHERLIBS_BYTE $OTHERLIBS_NATIVE $OCAMLLEX_BYTE \
   $OCAMLLEX_NATIVE $TOOLS_BYTE $TOOLS_NATIVE $DEBUGGER  \
   $OCAMLDOC_BYTE $OCAMLDOC_NATIVE $OCAMLBUILD_BYTE $CAMLP4_BYTE $CAMLP4_NATIVE
+
+cd tools
+make objinfo_helper
+cd ..
 installbin tools/ocamldep.native$EXE $BINDIR/ocamldep.opt$EXE
 
 echo "Installing some tools..."
+installbin tools/objinfo.byte$EXE $BINDIR/ocamlobjinfo$EXE
+installbin ../tools/objinfo_helper$EXE $LIBDIR/objinfo_helper$EXE
 installbin tools/ocamlcp.byte$EXE $BINDIR/ocamlcp$EXE
 installbin tools/ocamldep.byte$EXE $BINDIR/ocamldep$EXE
 installbin tools/ocamlmklib.byte$EXE $BINDIR/ocamlmklib$EXE

build/ocamlbuild-byte-only.sh

 #                                                                       #
 #   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.         #
+#   under the terms of the Q Public License version 1.0.                #
 #                                                                       #
 #########################################################################
 

build/ocamlbuild-native-only.sh

 #                                                                       #
 #   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.         #
+#   under the terms of the Q Public License version 1.0.                #
 #                                                                       #
 #########################################################################
 

build/ocamlbuildlib-native-only.sh

 #                                                                       #
 #   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.         #
+#   under the terms of the Q Public License version 1.0.                #
 #                                                                       #
 #########################################################################
 

build/otherlibs-targets.sh

 #                                                                       #
 #   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.         #
+#   under the terms of the Q Public License version 1.0.                #
 #                                                                       #
 #########################################################################
 
                  ocamlbuild/ocamlbuild.byte$EXE \
                  ocamlbuild/ocamlbuildlight.byte$EXE"
 TOPLEVEL=ocaml$EXE
-TOOLS_BYTE="tools/ocamldep.byte$EXE tools/profiling.cmo \
+TOOLS_BYTE="tools/objinfo.byte$EXE \
+            tools/ocamldep.byte$EXE tools/profiling.cmo \
             tools/ocamlprof.byte$EXE tools/ocamlcp.byte$EXE \
             tools/ocamlmktop.byte$EXE tools/ocamlmklib$EXE \
             tools/scrapelabels.byte tools/addlabels.byte \
 #                                                                       #
 #   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.         #
+#   under the terms of the Q Public License version 1.0.                #
 #                                                                       #
 #########################################################################
 

bytecomp/bytegen.ml

   | Lapply(func, args, loc) ->
       let nargs = List.length args in
       if is_tailcall cont then begin
-        Stypes.record (Stypes.An_call (loc, Annot.Tail));
         comp_args env args sz
           (Kpush :: comp_expr env func (sz + nargs)
             (Kappterm(nargs, sz + nargs) :: discard_dead_code cont))
       end else begin
-        Stypes.record (Stypes.An_call (loc, Annot.Stack));
         if nargs < 4 then
           comp_args env args sz
             (Kpush :: comp_expr env func (sz + nargs) (Kapply nargs :: cont))
                       (Kapply nargs :: cont1))
         end
       end
-  | Lsend(kind, met, obj, args) ->
+  | Lsend(kind, met, obj, args, _) ->
       let args = if kind = Cached then List.tl args else args in
       let nargs = List.length args + 1 in
       let getmethod, args' =
       | Lev_after ty ->
           let info =
             match lam with
-              Lapply(_, args, _)   -> Event_return (List.length args)
-            | Lsend(_, _, _, args) -> Event_return (List.length args + 1)
-            | _                 -> Event_other
+              Lapply(_, args, _)      -> Event_return (List.length args)
+            | Lsend(_, _, _, args, _) -> Event_return (List.length args + 1)
+            | _                       -> Event_other
           in
           let ev = event (Event_after ty) info in
           let cont1 = add_event ev cont in

bytecomp/bytelink.ml

   begin try
     (* The bytecode *)
     output_string outchan "\
-#ifdef __cplusplus\n\
-extern \"C\" {\n\
-#endif\n\
-#include <caml/mlvalues.h>\n\
-CAMLextern void caml_startup_code(\n\
-           code_t code, asize_t code_size,\n\
-           char *data, asize_t data_size,\n\
-           char *section_table, asize_t section_table_size,\n\
-           char **argv);\n";
+#ifdef __cplusplus\
+\nextern \"C\" {\
+\n#endif\
+\n#include <caml/mlvalues.h>\
+\nCAMLextern void caml_startup_code(\
+\n           code_t code, asize_t code_size,\
+\n           char *data, asize_t data_size,\
+\n           char *section_table, asize_t section_table_size,\
+\n           char **argv);\n";
     output_string outchan "static int caml_code[] = {\n";
     Symtable.init();
     Consistbl.clear crc_interfaces;
     (* The table of primitives *)
     Symtable.output_primitive_table outchan;
     (* The entry point *)
-    output_string outchan "\n\
-void caml_startup(char ** argv)\n\
-{\n\
-  caml_startup_code(caml_code, sizeof(caml_code),\n\
-                    caml_data, sizeof(caml_data),\n\
-                    caml_sections, sizeof(caml_sections),\n\
-                    argv);\n\
-}\n\
-#ifdef __cplusplus\n\
-}\n\
-#endif\n";
+    output_string outchan "\
+\nvoid caml_startup(char ** argv)\
+\n{\
+\n  caml_startup_code(caml_code, sizeof(caml_code),\
+\n                    caml_data, sizeof(caml_data),\
+\n                    caml_sections, sizeof(caml_sections),\
+\n                    argv);\
+\n}\
+\n#ifdef __cplusplus\
+\n}\
+\n#endif\n";
     close_out outchan
   with x ->
     close_out outchan;

bytecomp/bytepackager.ml

    SETGLOBAL relocations that correspond to one of the units being
    consolidated. *)
 
-let rename_relocation objfile mapping defined base (rel, ofs) =
+let rename_relocation packagename objfile mapping defined base (rel, ofs) =
   let rel' =
     match rel with
       Reloc_getglobal id ->
           then Reloc_getglobal id'
           else raise(Error(Forward_reference(objfile, id)))
         with Not_found ->
-          rel
+          (* PR#5276: unique-ize dotted global names, which appear
+             if one of the units being consolidated is itself a packed
+             module. *)
+          let name = Ident.name id in
+          if String.contains name '.' then
+            Reloc_getglobal (Ident.create_persistent (packagename ^ "." ^ name))
+          else
+            rel
         end
     | Reloc_setglobal id ->
         begin try
           then raise(Error(Multiple_definition(objfile, id)))
           else Reloc_setglobal id'
         with Not_found ->
-          rel
+          (* PR#5276, as above *)
+          let name = Ident.name id in
+          if String.contains name '.' then
+	    Reloc_setglobal (Ident.create_persistent (packagename ^ "." ^ name))
+          else
+            rel
         end
     | _ ->
         rel in
    Accumulate relocs, debug info, etc.
    Return size of bytecode. *)
 
-let rename_append_bytecode oc mapping defined ofs prefix subst objfile compunit =
+let rename_append_bytecode packagename oc mapping defined ofs prefix subst objfile compunit =
   let ic = open_in_bin objfile in
   try
     Bytelink.check_consistency objfile compunit;
     List.iter
-      (rename_relocation objfile mapping defined ofs)
+      (rename_relocation packagename objfile mapping defined ofs)
       compunit.cu_reloc;
     primitives := compunit.cu_primitives @ !primitives;
     if compunit.cu_force_link then force_link := true;
 (* Same, for a list of .cmo and .cmi files.
    Return total size of bytecode. *)
 
-let rec rename_append_bytecode_list oc mapping defined ofs prefix subst = function
+let rec rename_append_bytecode_list packagename oc mapping defined ofs prefix subst = function
     [] ->
       ofs
   | m :: rem ->
       match m.pm_kind with
       | PM_intf ->
-          rename_append_bytecode_list oc mapping defined ofs prefix subst rem
+          rename_append_bytecode_list packagename oc mapping defined ofs prefix subst rem
       | PM_impl compunit ->
           let size =
-            rename_append_bytecode oc mapping defined ofs prefix subst
+            rename_append_bytecode packagename oc mapping defined ofs prefix subst
                                    m.pm_file compunit in
           let id = Ident.create_persistent m.pm_name in
           let root = Path.Pident (Ident.create_persistent prefix) in
-          rename_append_bytecode_list
+          rename_append_bytecode_list packagename
             oc mapping (id :: defined)
             (ofs + size) prefix (Subst.add_module id (Path.Pdot (root, Ident.name id, Path.nopos)) subst) rem
 
     let pos_depl = pos_out oc in
     output_binary_int oc 0;
     let pos_code = pos_out oc in
-    let ofs = rename_append_bytecode_list oc mapping [] 0 targetname Subst.identity members in
+    let ofs = rename_append_bytecode_list targetname oc mapping [] 0 targetname Subst.identity members in
     build_global_target oc targetname members mapping ofs coercion;
     let pos_debug = pos_out oc in
     if !Clflags.debug && !events <> [] then

bytecomp/lambda.ml

   | Lwhile of lambda * lambda
   | Lfor of Ident.t * lambda * lambda * direction_flag * lambda
   | Lassign of Ident.t * lambda
-  | Lsend of meth_kind * lambda * lambda * lambda list
+  | Lsend of meth_kind * lambda * lambda * lambda list * Location.t
   | Levent of lambda * lambda_event
   | Lifused of Ident.t * lambda
 
       same b1 b2 && df1 = df2 && same c1 c2
   | Lassign(id1, a1), Lassign(id2, a2) ->
       Ident.same id1 id2 && same a1 a2
-  | Lsend(k1, a1, b1, cl1), Lsend(k2, a2, b2, cl2) ->
+  | Lsend(k1, a1, b1, cl1, _), Lsend(k2, a2, b2, cl2, _) ->
       k1 = k2 && same a1 a2 && same b1 b2 && samelist same cl1 cl2
   | Levent(a1, ev1), Levent(a2, ev2) ->
       same a1 a2 && ev1.lev_loc = ev2.lev_loc
       f e1; f e2; f e3
   | Lassign(id, e) ->
       f e
-  | Lsend (k, met, obj, args) ->
+  | Lsend (k, met, obj, args, _) ->
       List.iter f (met::obj::args)
   | Levent (lam, evt) ->
       f lam
   free_ids (function Lvar id -> [id] | _ -> []) l
 
 let free_methods l =
-  free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> []) l
+  free_ids (function Lsend(Self, Lvar meth, obj, _, _) -> [meth] | _ -> []) l
 
 (* Check if an action has a "when" guard *)
 let raise_count = ref 0
   | Lwhile(e1, e2) -> Lwhile(subst e1, subst e2)
   | Lfor(v, e1, e2, dir, e3) -> Lfor(v, subst e1, subst e2, dir, subst e3)
   | Lassign(id, e) -> Lassign(id, subst e)
-  | Lsend (k, met, obj, args) ->
-      Lsend (k, subst met, subst obj, List.map subst args)
+  | Lsend (k, met, obj, args, loc) ->
+      Lsend (k, subst met, subst obj, List.map subst args, loc)
   | Levent (lam, evt) -> Levent (subst lam, evt)
   | Lifused (v, e) -> Lifused (v, subst e)
   and subst_decl (id, exp) = (id, subst exp)

bytecomp/lambda.mli

   | Lwhile of lambda * lambda
   | Lfor of Ident.t * lambda * lambda * direction_flag * lambda
   | Lassign of Ident.t * lambda
-  | Lsend of meth_kind * lambda * lambda * lambda list
+  | Lsend of meth_kind * lambda * lambda * lambda list * Location.t
   | Levent of lambda * lambda_event
   | Lifused of Ident.t * lambda
 

bytecomp/printlambda.ml

        lam hi lam body
   | Lassign(id, expr) ->
       fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr
-  | Lsend (k, met, obj, largs) ->
+  | Lsend (k, met, obj, largs, _) ->
       let args ppf largs =
         List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
       let kind =

bytecomp/simplif.ml

            dir, eliminate_ref id e3)
   | Lassign(v, e) ->
       Lassign(v, eliminate_ref id e)
-  | Lsend(k, m, o, el) ->
+  | Lsend(k, m, o, el, loc) ->
       Lsend(k, eliminate_ref id m, eliminate_ref id o,
-            List.map (eliminate_ref id) el)
+            List.map (eliminate_ref id) el, loc)
   | Levent(l, ev) ->
       Levent(eliminate_ref id l, ev)
   | Lifused(v, e) ->
       (* Lalias-bound variables are never assigned, so don't increase
          v's refcount *)
       count l
-  | Lsend(k, m, o, ll) -> List.iter count (m::o::ll)
+  | Lsend(k, m, o, ll, _) -> List.iter count (m::o::ll)
   | Levent(l, _) -> count l
   | Lifused(v, l) -> count l
 
   | Lfor(v, l1, l2, dir, l3) ->
       Lfor(v, simplif l1, simplif l2, dir, simplif l3)
   | Lassign(v, l) -> Lassign(v, simplif l)
-  | Lsend(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll)
+  | Lsend(k, m, o, ll, loc) -> Lsend(k, simplif m, simplif o, List.map simplif ll, loc)
   | Levent(l, ev) -> Levent(simplif l, ev)
   | Lifused(v, l) -> Lifused (v,simplif l)
   in
       (* Lalias-bound variables are never assigned, so don't increase
          v's refcount *)
       count bv l
-  | Lsend(_, m, o, ll) -> List.iter (count bv) (m::o::ll)
+  | Lsend(_, m, o, ll, _) -> List.iter (count bv) (m::o::ll)
   | Levent(l, _) -> count bv l
   | Lifused(v, l) ->
       if count_var v > 0 then count bv l
   | Lfor(v, l1, l2, dir, l3) ->
       Lfor(v, simplif l1, simplif l2, dir, simplif l3)
   | Lassign(v, l) -> Lassign(v, simplif l)
-  | Lsend(k, m, o, ll) -> Lsend(k, simplif m, simplif o, List.map simplif ll)
+  | Lsend(k, m, o, ll, loc) -> Lsend(k, simplif m, simplif o, List.map simplif ll, loc)
   | Levent(l, ev) -> Levent(simplif l, ev)
   | Lifused(v, l) ->
       if count_var v > 0 then simplif l else lambda_unit
   in
   simplif lam
 
-let simplify_lambda lam = simplify_lets (simplify_exits lam)
+(* Tail call info in annotation files *)
+
+let is_tail_native_heuristic : (int -> bool) ref =
+  ref (fun n -> true)
+
+let rec emit_tail_infos is_tail lambda =
+  let call_kind args =
+    if is_tail
+    && ((not !Clflags.native_code)
+        || (!is_tail_native_heuristic (List.length args)))
+   then Annot.Tail
+   else Annot.Stack in
+  match lambda with
+  | Lvar _ -> ()
+  | Lconst _ -> ()
+  | Lapply (func, l, loc) ->
+      list_emit_tail_infos false l;
+      Stypes.record (Stypes.An_call (loc, call_kind l))
+  | Lfunction (_, _, lam) ->
+      emit_tail_infos true lam
+  | Llet (_, _, lam, body) ->
+      emit_tail_infos false lam;
+      emit_tail_infos is_tail body
+  | Lletrec (bindings, body) ->
+      List.iter (fun (_, lam) -> emit_tail_infos false lam) bindings;
+      emit_tail_infos is_tail body
+  | Lprim (Pidentity, [arg]) ->
+      emit_tail_infos is_tail arg
+  | Lprim (Psequand, [arg1; arg2])
+  | Lprim (Psequor, [arg1; arg2]) ->
+      emit_tail_infos false arg1;
+      emit_tail_infos is_tail arg2
+  | Lprim (_, l) ->
+      list_emit_tail_infos false l
+  | Lswitch (lam, sw) ->
+      emit_tail_infos false lam;
+      list_emit_tail_infos_fun snd is_tail sw.sw_consts;
+      list_emit_tail_infos_fun snd is_tail sw.sw_blocks
+  | Lstaticraise (_, l) ->
+      list_emit_tail_infos false l
+  | Lstaticcatch (body, _, handler) ->
+      emit_tail_infos is_tail body;
+      emit_tail_infos is_tail handler
+  | Ltrywith (body, _, handler) ->
+      emit_tail_infos false body;
+      emit_tail_infos is_tail handler
+  | Lifthenelse (cond, ifso, ifno) ->
+      emit_tail_infos false cond;
+      emit_tail_infos is_tail ifso;
+      emit_tail_infos is_tail ifno
+  | Lsequence (lam1, lam2) ->
+      emit_tail_infos false lam1;
+      emit_tail_infos is_tail lam2
+  | Lwhile (cond, body) ->
+      emit_tail_infos false cond;
+      emit_tail_infos false body
+  | Lfor (_, low, high, _, body) ->
+      emit_tail_infos false low;
+      emit_tail_infos false high;
+      emit_tail_infos false body
+  | Lassign (_, lam) ->
+      emit_tail_infos false lam
+  | Lsend (_, meth, obj, args, loc) ->
+      emit_tail_infos false meth;
+      emit_tail_infos false obj;
+      list_emit_tail_infos false args;
+      Stypes.record (Stypes.An_call (loc, call_kind (obj :: args)))
+  | Levent (lam, _) ->
+      emit_tail_infos is_tail lam
+  | Lifused (_, lam) ->
+      emit_tail_infos is_tail lam
+and list_emit_tail_infos_fun f is_tail =
+  List.iter (fun x -> emit_tail_infos is_tail (f x))
+and list_emit_tail_infos is_tail =
+  List.iter (emit_tail_infos is_tail)
+
+(* The entry point:
+   simplification + emission of tailcall annotations, if needed. *)
+
+let simplify_lambda lam =
+  let res = simplify_lets (simplify_exits lam) in
+  if !Clflags.annotations then emit_tail_infos true res;
+  res

bytecomp/simplif.mli

 
 (* $Id$ *)
 
-(* Elimination of useless Llet(Alias) bindings *)
+(* Elimination of useless Llet(Alias) bindings.
+   Transformation of let-bound references into variables.
+   Simplification over staticraise/staticcatch constructs.
+   Generation of tail-call annotations if -annot is set. *)
 
 open Lambda
 
 val simplify_lambda: lambda -> lambda
+
+(* To be filled by asmcomp/selectgen.ml *)
+val is_tail_native_heuristic: (int -> bool) ref
+                          (* # arguments -> can tailcall *)

bytecomp/translclass.ml

         "var", [Lvar n]
     | Lprim(Pfield n, [Lvar e]) when Ident.same e env ->
         "env", [Lvar env2; Lconst(Const_pointer n)]
-    | Lsend(Self, met, Lvar s, []) when List.mem s self ->
+    | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
         "meth", [met]
     | _ -> raise Not_found
   in
   | Lapply(f, [p; arg], _) when const_path f && const_path p ->
       let s, args = conv arg in
       ("app_const_"^s, f :: p :: args)
-  | Lsend(Self, Lvar n, Lvar s, [arg]) when List.mem s self ->
+  | Lsend(Self, Lvar n, Lvar s, [arg], _) when List.mem s self ->
       let s, args = conv arg in
       ("meth_app_"^s, Lvar n :: args)
-  | Lsend(Self, met, Lvar s, []) when List.mem s self ->
+  | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
       ("get_meth", [met])
-  | Lsend(Public, met, arg, []) ->
+  | Lsend(Public, met, arg, [], _) ->
       let s, args = conv arg in
       ("send_"^s, met :: args)
-  | Lsend(Cached, met, arg, [_;_]) ->
+  | Lsend(Cached, met, arg, [_;_], _) ->
       let s, args = conv arg in
       ("send_"^s, met :: args)
   | Lfunction (Curried, [x], body) ->

bytecomp/translcore.ml

       if public_send || p.prim_name = "%sendself" then
         let kind = if public_send then Public else Self in
         let obj = Ident.create "obj" and meth = Ident.create "meth" in
-        Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, []))
+        Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, [], e.exp_loc))
       else if p.prim_name = "%sendcache" then
         let obj = Ident.create "obj" and meth = Ident.create "meth" in
         let cache = Ident.create "cache" and pos = Ident.create "pos" in
         Lfunction(Curried, [obj; meth; cache; pos],
-                  Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos]))
+                  Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos], e.exp_loc))
       else
         transl_primitive p
   | Texp_ident(path, {val_kind = Val_anc _}) ->
       if public_send || p.prim_name = "%sendself" then
         let kind = if public_send then Public else Self in
         let obj = List.hd argl in
-        wrap (Lsend (kind, List.nth argl 1, obj, []))
+        wrap (Lsend (kind, List.nth argl 1, obj, [], e.exp_loc))
       else if p.prim_name = "%sendcache" then
         match argl with [obj; meth; cache; pos] ->
-          wrap (Lsend(Cached, meth, obj, [cache; pos]))
+          wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc))
         | _ -> assert false
       else begin
         let prim = transl_prim p args in
       let obj = transl_exp expr in
       let lam =
         match met with
-          Tmeth_val id -> Lsend (Self, Lvar id, obj, [])
+          Tmeth_val id -> Lsend (Self, Lvar id, obj, [], e.exp_loc)
         | Tmeth_name nm ->
             let (tag, cache) = Translobj.meth obj nm in
             let kind = if cache = [] then Public else Cached in
-            Lsend (kind, tag, obj, cache)
+            Lsend (kind, tag, obj, cache, e.exp_loc)
       in
       event_after e lam
   | Texp_new (cl, _) ->
 and transl_apply lam sargs loc =
   let lapply funct args =
     match funct with
-      Lsend(k, lmet, lobj, largs) ->
-        Lsend(k, lmet, lobj, largs @ args)
-    | Levent(Lsend(k, lmet, lobj, largs), _) ->
-        Lsend(k, lmet, lobj, largs @ args)
+      Lsend(k, lmet, lobj, largs, loc) ->
+        Lsend(k, lmet, lobj, largs @ args, loc)
+    | Levent(Lsend(k, lmet, lobj, largs, loc), _) ->
+        Lsend(k, lmet, lobj, largs @ args, loc)
     | Lapply(lexp, largs, _) ->
         Lapply(lexp, largs @ args, loc)
     | lexp ->

byterun/compare.c

       if (Is_long(v2))
         return Long_val(v1) - Long_val(v2);
       /* Subtraction above cannot overflow and cannot result in UNORDERED */
-      if (Is_in_value_area(v2) &&
-          Tag_val(v2) == Forward_tag) {
-        v2 = Forward_val(v2);
-        continue;
+      if (Is_in_value_area(v2)) {
+        switch (Tag_val(v2)) {
+        case Forward_tag: 
+          v2 = Forward_val(v2);
+          continue;
+        case Custom_tag: {
+          int res;
+          int (*compare)(value v1, value v2) = Custom_ops_val(v2)->compare_ext;
+          if (compare == NULL) break;  /* for backward compatibility */
+          caml_compare_unordered = 0;
+          res = compare(v1, v2);
+          if (caml_compare_unordered && !total) return UNORDERED;
+          if (res != 0) return res;
+          goto next_item;
+        }
+        default: /*fallthrough*/;
+        }
       }
       return LESS;                /* v1 long < v2 block */
     }
     if (Is_long(v2)) {
-      if (Is_in_value_area(v1) &&
-          Tag_val(v1) == Forward_tag) {
-        v1 = Forward_val(v1);
-        continue;
+      if (Is_in_value_area(v1)) {
+        switch (Tag_val(v1)) {
+        case Forward_tag:
+          v1 = Forward_val(v1);
+          continue;
+        case Custom_tag: {
+          int res;
+          int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare_ext;
+          if (compare == NULL) break;  /* for backward compatibility */
+          caml_compare_unordered = 0;
+          res = compare(v1, v2);
+          if (caml_compare_unordered && !total) return UNORDERED;
+          if (res != 0) return res;
+          goto next_item;
+        }
+        default: /*fallthrough*/;
+        }
       }
       return GREATER;            /* v1 block > v2 long */
     }
     if (t1 != t2) return (intnat)t1 - (intnat)t2;
     switch(t1) {
     case String_tag: {
-      mlsize_t len1, len2, len;
-      unsigned char * p1, * p2;
+      mlsize_t len1, len2;
+      int res;
       if (v1 == v2) break;
       len1 = caml_string_length(v1);
       len2 = caml_string_length(v2);
-      for (len = (len1 <= len2 ? len1 : len2),
-             p1 = (unsigned char *) String_val(v1),
-             p2 = (unsigned char *) String_val(v2);
-           len > 0;
-           len--, p1++, p2++)
-        if (*p1 != *p2) return (intnat)*p1 - (intnat)*p2;
+      res = memcmp(String_val(v1), String_val(v2), len1 <= len2 ? len1 : len2);
+      if (res < 0) return LESS;
+      if (res > 0) return GREATER;
       if (len1 != len2) return len1 - len2;
       break;
     }
     case Custom_tag: {
       int res;
       int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare;
+      /* Hardening against comparisons between different types */
+      if (compare != Custom_ops_val(v2)->compare) {
+        return strcmp(Custom_ops_val(v1)->identifier,
+                      Custom_ops_val(v2)->identifier) < 0
+               ? LESS : GREATER;
+      }
       if (compare == NULL) {
         compare_free_stack();
         caml_invalid_argument("equal: abstract value");
       }
       caml_compare_unordered = 0;
-      res = Custom_ops_val(v1)->compare(v1, v2);
+      res = compare(v1, v2);
       if (caml_compare_unordered && !total) return UNORDERED;
       if (res != 0) return res;
       break;
                     /*out*/ uintnat * wsize_32 /*size in bytes*/,
                     /*out*/ uintnat * wsize_64 /*size in bytes*/);
   uintnat (*deserialize)(void * dst);
+  int (*compare_ext)(value v1, value v2);
 };
 
 #define custom_finalize_default NULL
 #define custom_hash_default NULL
 #define custom_serialize_default NULL
 #define custom_deserialize_default NULL
+#define custom_compare_ext_default NULL
 
 #define Custom_ops_val(v) (*((struct custom_operations **) (v)))
 
 
 /* Raising exceptions from C. */
 
+#include <stdio.h>
+#include <stdlib.h>
 #include "alloc.h"
 #include "fail.h"
 #include "io.h"
   CAMLnoreturn;
 }
 
+/* PR#5115: Failure and Invalid_argument can be triggered by
+   input_value while reading the initial value of [caml_global_data]. */
+
 CAMLexport void caml_failwith (char const *msg)
 {
+  if (caml_global_data == 0) {
+    fprintf(stderr, "Fatal error: exception Failure(\"%s\")\n", msg);
+    exit(2);
+  }
   caml_raise_with_string(Field(caml_global_data, FAILURE_EXN), msg);
 }
 
 CAMLexport void caml_invalid_argument (char const *msg)
 {
+  if (caml_global_data == 0) {
+    fprintf(stderr, "Fatal error: exception Invalid_argument(\"%s\")\n", msg);
+    exit(2);
+  }
   caml_raise_with_string(Field(caml_global_data, INVALID_EXN), msg);
 }
 

byterun/gc_ctrl.c

 
 CAMLprim value caml_gc_compaction(value v)
 {                                                    Assert (v == Val_unit);
+  caml_gc_message (0x10, "Heap compaction requested\n", 0);
   caml_empty_minor_heap ();
   caml_finish_major_cycle ();
+  caml_final_do_calls ();
+  caml_empty_minor_heap ();
   caml_finish_major_cycle ();
   caml_compact_heap ();
   caml_final_do_calls ();
 {
   uintnat major_heap_size = Bsize_wsize (norm_heapincr (major_size));
 
-  caml_page_table_initialize(Bsize_wsize(minor_size) + major_heap_size);
+  if (caml_page_table_initialize(Bsize_wsize(minor_size) + major_heap_size)){
+    caml_fatal_error ("OCaml runtime error: cannot initialize page table\n");
+  }
   caml_set_minor_heap_size (Bsize_wsize (norm_minsize (minor_size)));
   caml_major_heap_increment = Bsize_wsize (norm_heapincr (major_incr));
   caml_percent_free = norm_pfree (percent_fr);
 {
   intnat l = Nativeint_val(v);
 #ifdef ARCH_SIXTYFOUR
-  if (l <= 0x7FFFFFFFL && l >= -0x80000000L) {
+  if (l >= -((intnat)1 << 31) && l < ((intnat)1 << 31)) {
     caml_serialize_int_1(1);
     caml_serialize_int_4((int32) l);
   } else {

byterun/major_gc.h

 void caml_init_major_heap (asize_t);           /* size in bytes */
 asize_t caml_round_heap_chunk_size (asize_t);  /* size in bytes */
 void caml_darken (value, value *);
-intnat caml_major_collection_slice (long);
+intnat caml_major_collection_slice (intnat);
 void major_collection (void);
 void caml_finish_major_cycle (void);
 
 CAMLexport value * caml_extern_sp;
 CAMLexport value * caml_trapsp;
 CAMLexport value * caml_trap_barrier;
-value caml_global_data;
+value caml_global_data = 0;
 
 uintnat caml_max_stack_size;            /* also used in gc_ctrl.c */
 

byterun/startup.c

 static void scanmult (char *opt, uintnat *var)
 {
   char mult = ' ';
-  int val;
+  unsigned int val;
   sscanf (opt, "=%u%c", &val, &mult);
   sscanf (opt, "=0x%x%c", &val, &mult);
   switch (mult) {
   /* open on a named FIFO can block (PR#1533) */
   caml_enter_blocking_section();
   fd = open(p, flags, perm);
+  /* fcntl on a fd can block (PR#5069)*/
+#if defined(F_SETFD) && defined(FD_CLOEXEC)
+  if (fd != -1)
+    fcntl(fd, F_SETFD, FD_CLOEXEC);
+#endif
   caml_leave_blocking_section();
   caml_stat_free(p);
   if (fd == -1) caml_sys_error(path);
-#if defined(F_SETFD) && defined(FD_CLOEXEC)
-  fcntl(fd, F_SETFD, FD_CLOEXEC);
-#endif
   CAMLreturn(Val_long(fd));
 }
 

camlp4/Camlp4/Camlp4Ast.partial.ml

     | MtSig of loc and sig_item
       (* mt with wc *)
     | MtWit of loc and module_type and with_constr
+      (* module type of m *)
+    | MtOf of loc and module_expr
     | MtAnt of loc and string (* $s$ *) ]
   and sig_item =
     [ SgNil of loc

camlp4/Camlp4/Printers/OCaml.ml

     method reset =      {< pipe = False; semi = False >};
 
     value semisep : sep = ";;";
+    value no_semisep : sep = ""; (* used to mark where ";;" should not occur *)
     value mode = if comments then `comments else `no_comments;
     value curry_constr = init_curry_constr;
     value var_conversion = False;
     let () = o#node f mt Ast.loc_of_module_type in
     match mt with
     [ <:module_type<>> -> assert False
+    | <:module_type< module type of $me$ >> -> pp f "@[<2>module type of@ %a@]" o#module_expr me
     | <:module_type< $id:i$ >> -> o#ident f i
     | <:module_type< $anti:s$ >> -> o#anti f s
     | <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> ->
       | <:class_sig_item< $csg1$; $csg2$ >> ->
             do { o#class_sig_item f csg1; cut f; o#class_sig_item f csg2 }
       | <:class_sig_item< constraint $t1$ = $t2$ >> ->
-            pp f "@[<2>constraint@ %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 semisep
+            pp f "@[<2>constraint@ %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 no_semisep
       | <:class_sig_item< inherit $ct$ >> ->
-            pp f "@[<2>inherit@ %a%(%)@]" o#class_type ct semisep
+            pp f "@[<2>inherit@ %a%(%)@]" o#class_type ct no_semisep
       | <:class_sig_item< method $private:pr$ $s$ : $t$ >> ->
             pp f "@[<2>method %a%a :@ %a%(%)@]" o#private_flag pr o#var s
-              o#ctyp t semisep
+              o#ctyp t no_semisep
       | <:class_sig_item< method virtual $private:pr$ $s$ : $t$ >> ->
             pp f "@[<2>method virtual %a%a :@ %a%(%)@]"
-              o#private_flag pr o#var s o#ctyp t semisep
+              o#private_flag pr o#var s o#ctyp t no_semisep
       | <:class_sig_item< value $mutable:mu$ $virtual:vi$ $s$ : $t$ >> ->
             pp f "@[<2>%s %a%a%a :@ %a%(%)@]"
               o#value_val o#mutable_flag mu o#virtual_flag vi o#var s o#ctyp t
-              semisep
+              no_semisep
       | <:class_sig_item< $anti:s$ >> ->
-            pp f "%a%(%)" o#anti s semisep ];
+            pp f "%a%(%)" o#anti s no_semisep ];
 
     method class_str_item f cst =
       let () = o#node f cst Ast.loc_of_class_str_item in
       | <:class_str_item< $cst1$; $cst2$ >> ->
             do { o#class_str_item f cst1; cut f; o#class_str_item f cst2 }
       | <:class_str_item< constraint $t1$ = $t2$ >> ->
-            pp f "@[<2>constraint %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 semisep
+            pp f "@[<2>constraint %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 no_semisep
       | <:class_str_item< inherit $override:ov$ $ce$ >> ->
-            pp f "@[<2>inherit%a@ %a%(%)@]" o#override_flag ov o#class_expr ce semisep
+            pp f "@[<2>inherit%a@ %a%(%)@]" o#override_flag ov o#class_expr ce no_semisep
       | <:class_str_item< inherit $override:ov$ $ce$ as $lid:s$ >> ->
-            pp f "@[<2>inherit%a@ %a as@ %a%(%)@]" o#override_flag ov o#class_expr ce o#var s semisep
+            pp f "@[<2>inherit%a@ %a as@ %a%(%)@]" o#override_flag ov o#class_expr ce o#var s no_semisep
       | <:class_str_item< initializer $e$ >> ->
-            pp f "@[<2>initializer@ %a%(%)@]" o#expr e semisep
+            pp f "@[<2>initializer@ %a%(%)@]" o#expr e no_semisep
       | <:class_str_item< method $override:ov$ $private:pr$ $s$ = $e$ >> ->
             pp f "@[<2>method%a %a%a =@ %a%(%)@]"
-              o#override_flag ov o#private_flag pr o#var s o#expr e semisep
+              o#override_flag ov o#private_flag pr o#var s o#expr e no_semisep
       | <:class_str_item< method $override:ov$ $private:pr$ $s$ : $t$ = $e$ >> ->
             pp f "@[<2>method%a %a%a :@ %a =@ %a%(%)@]"
-              o#override_flag ov o#private_flag pr o#var s o#ctyp t o#expr e semisep
+              o#override_flag ov o#private_flag pr o#var s o#ctyp t o#expr e no_semisep
       | <:class_str_item< method virtual $private:pr$ $s$ : $t$ >> ->
             pp f "@[<2>method virtual@ %a%a :@ %a%(%)@]"
-              o#private_flag pr o#var s o#ctyp t semisep
+              o#private_flag pr o#var s o#ctyp t no_semisep
       | <:class_str_item< value virtual $mutable:mu$ $s$ : $t$ >> ->
             pp f "@[<2>%s virtual %a%a :@ %a%(%)@]"
-              o#value_val o#mutable_flag mu o#var s o#ctyp t semisep
+              o#value_val o#mutable_flag mu o#var s o#ctyp t no_semisep
       | <:class_str_item< value $override:ov$ $mutable:mu$ $s$ = $e$ >> ->
             pp f "@[<2>%s%a %a%a =@ %a%(%)@]"
-              o#value_val o#override_flag ov o#mutable_flag mu o#var s o#expr e semisep
+              o#value_val o#override_flag ov o#mutable_flag mu o#var s o#expr e no_semisep
       | <:class_str_item< $anti:s$ >> ->
-            pp f "%a%(%)" o#anti s semisep ];
+            pp f "%a%(%)" o#anti s no_semisep ];
 
     method implem f st =
       match st with

camlp4/Camlp4/Printers/OCaml.mli

     value pipe : bool;
     value semi : bool;
     value semisep : sep;
+    value no_semisep : sep;
     method value_val : string;
     method value_let : string;
     method andsep : sep;

camlp4/Camlp4/Printers/OCamlr.ml

     inherit PP_o.printer ~curry_constr:init_curry_constr ~comments () as super;
 
     value! semisep : sep = ";";
+    value! no_semisep : sep = ";";
     value mode = if comments then `comments else `no_comments;
     value curry_constr = init_curry_constr;
     value first_match_case = True;
     | <:class_expr< virtual $lid:i$ >> ->
           pp f "@[<2>virtual@ %a@]" o#var i
     | <:class_expr< virtual $lid:i$ [ $t$ ] >> ->
-          pp f "@[<2>virtual@ %a@ @[<1>[%a]@]@]" o#var i o#ctyp t
+          pp f "@[<2>virtual@ %a@ @[<1>[%a]@]@]" o#var i o#class_params t
     | ce -> super#class_expr f ce ];
   end;
 

camlp4/Camlp4/Register.ml

 value register_sig_item_parser f = sig_item_parser.val := f;
 value register_parser f g =
   do { str_item_parser.val := f; sig_item_parser.val := g };
+value current_parser () = (str_item_parser.val, sig_item_parser.val);
 
 value register_str_item_printer f = str_item_printer.val := f;
 value register_sig_item_printer f = sig_item_printer.val := f;
 value register_printer f g =
   do { str_item_printer.val := f; sig_item_printer.val := g };
+value current_printer () = (str_item_printer.val, sig_item_printer.val);
 
 module Plugin (Id : Sig.Id) (Maker : functor (Unit : sig end) -> sig end) = struct
   declare_dyn_module Id.name (fun _ -> let module M = Maker (struct end) in ());

camlp4/Camlp4/Register.mli

 value register_str_item_parser : parser_fun PreCast.Ast.str_item -> unit;
 value register_sig_item_parser : parser_fun PreCast.Ast.sig_item -> unit;
 value register_parser : parser_fun PreCast.Ast.str_item -> parser_fun PreCast.Ast.sig_item -> unit;
+value current_parser : unit -> (parser_fun PreCast.Ast.str_item * parser_fun PreCast.Ast.sig_item);
 
 module Parser
   (Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) -> (Sig.Parser Ast).S) : sig end;
 value register_str_item_printer : printer_fun PreCast.Ast.str_item -> unit;
 value register_sig_item_printer : printer_fun PreCast.Ast.sig_item -> unit;
 value register_printer : printer_fun PreCast.Ast.str_item -> printer_fun PreCast.Ast.sig_item -> unit;
+value current_printer : unit -> (printer_fun PreCast.Ast.str_item * printer_fun PreCast.Ast.sig_item);
 
 module Printer
   (Id : Sig.Id)

camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml

         mkmty loc (Pmty_signature (sig_item sl []))
     | <:module_type@loc< $mt$ with $wc$ >> ->
         mkmty loc (Pmty_with (module_type mt) (mkwithc wc []))
+    | <:module_type@loc< module type of $me$ >> ->
+        mkmty loc (Pmty_typeof (module_expr me))
     | <:module_type< $anti:_$ >> -> assert False ]
   and sig_item s l =
     match s with

camlp4/Camlp4/Struct/Grammar/Structure.ml

 
   type token_info = { prev_loc : Loc.t
                     ; cur_loc : Loc.t
+                    ; prev_loc_only : bool
                     };
 
   type token_stream = Stream.t (Token.t * token_info);