Commits

camlspotter committed 0a3fcc6

svn rev 11009, 3.12.1+dev6 (2011-03-06)

Comments (0)

Files changed (313)

 _build
 _log
 myocamlbuild_config.ml
-ocamlbuild-mixed-boot
 ocamlnat
-Objective Caml 3.13.0:
+Objective Caml 3.12.1:
 ----------------------
 
-- Warning 28 is now enabled by default.
+- Changed default minor heap size from 32k to 256k words.
+
+Bug fixes:
+- PR#4345, PR#4767: problems with camlp4 printing of float values
+- PR#4380: ocamlbuild should not use tput on windows
+- PR#4552: ocamlbuild does not create symlinks when using '.itarget' file
+- PR#4673, PR#5144: camlp4 fails on object copy syntax
+- 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#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#5071, PR#5129, PR#5134: inconsistencies between camlp4 and camlp4* binaries
+- PR#5080, PR#5104: regression in type constructor handling by 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#5110: invalid module name when using optional argument
+- PR#5118: Camlp4o and integer literals
+- PR#5128: typo in 'Camlp4ListComprehension' syntax extension
+- 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#5177: Gc.compact implies Gc.full_major
+- 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#5237: incorrect .size directives generated for x86-32 and x86-64
+
+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
 
 
 Objective Caml 3.12.0:
         run-time system manually written in assembly language.
         This assembler must preprocess its input with the C preprocessor.
 
--with-debug-runtime
-        Compile and install the debug version of the runtimes, useful
-        for debugging C stubs and other low-level code.
-
 -verbose
         Verbose output of the configuration tests. Use it if the outcome
         of configure is not what you were expecting.
         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".
 
 
 # Camlp4
 
-camlp4out: ocamlc ocamlbuild.byte
+camlp4out: ocamlc otherlibraries ocamlbuild-mixed-boot ocamlbuild.byte
 	./build/camlp4-byte-only.sh
 
 camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot ocamlbuild.native
 
 # Ocamlbuild
 
-ocamlbuild.byte: ocamlc ocamlbuild-mixed-boot
+ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-mixed-boot
 	./build/ocamlbuild-byte-only.sh
 
-ocamlbuild.native: ocamlopt ocamlbuild-mixed-boot
+ocamlbuild.native: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot
 	./build/ocamlbuild-native-only.sh
-ocamlbuildlib.native: ocamlopt ocamlbuild-mixed-boot
+ocamlbuildlib.native: ocamlopt otherlibrariesopt ocamlbuild-mixed-boot
 	./build/ocamlbuildlib-native-only.sh
 
-ocamlbuild-mixed-boot: ocamlc
+ocamlbuild-mixed-boot: ocamlc otherlibraries
 	./build/mixed-boot.sh
-	touch ocamlbuild-mixed-boot
 
 partialclean::
-	rm -rf _build ocamlbuild-mixed-boot
+	rm -rf _build
 
 # Check that the stack limit is reasonable.
 
-3.13.0+dev3 (2011-03-07)
+3.12.1+dev6 (2011-03-06)
 
 # The version string is the first line of this file.
 # It must be in the format described in stdlib/sys.mli

asmcomp/.cvsignore

 selection.ml
 reload.ml
 scheduling.ml
-*.cm*
-*.o

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

   let libname =
     if !Clflags.gprofile
     then "libasmrunp" ^ ext_lib
-    else "libasmrun" ^ !Clflags.runtime_variant ^ ext_lib in
+    else "libasmrun" ^ ext_lib in
   try
     if !Clflags.nopervasives then []
     else [ find_in_path !load_path libname ]

asmcomp/clambda.ml

 
 type ulambda =
     Uvar of Ident.t
-  | Uconst of structured_constant * string option
+  | Uconst of structured_constant
   | Udirect_apply of function_label * ulambda list * Debuginfo.t
   | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t
   | Uclosure of (function_label * int * Ident.t list * ulambda) list

asmcomp/clambda.mli

 
 type ulambda =
     Uvar of Ident.t
-  | Uconst of structured_constant * string option
+  | Uconst of structured_constant
   | Udirect_apply of function_label * ulambda list * Debuginfo.t
   | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t
   | Uclosure of (function_label * int * Ident.t list * ulambda) list

asmcomp/closure.ml

 let occurs_var var u =
   let rec occurs = function
       Uvar v -> v = var
-    | Uconst (cst,_) -> false
+    | Uconst cst -> false
     | Udirect_apply(lbl, args, _) -> List.exists occurs args
     | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args
     | Uclosure(fundecls, clos) -> List.exists occurs clos
     if !size > threshold then raise Exit;
     match lam with
       Uvar v -> ()
-    | Uconst(
-	(Const_base(Const_int _ | Const_char _ | Const_float _ |
+    | Uconst(Const_base(Const_int _ | Const_char _ | Const_float _ |
                         Const_int32 _ | Const_int64 _ | Const_nativeint _) |
-             Const_pointer _), _) -> incr size
-(* Structured Constants are now emitted during closure conversion. *)
-    | Uconst (_, Some _) -> incr size
+             Const_pointer _) -> incr size
     | Uconst _ ->
         raise Exit (* avoid duplication of structured constants *)
     | Udirect_apply(fn, args, _) ->
 
 let rec is_pure_clambda = function
     Uvar v -> true
-  | Uconst _ -> true
+  | Uconst cst -> true
   | Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ |
            Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets |
            Parraysetu _ | Parraysets _ | Pbigarrayset _), _, _) -> false
 
 (* Simplify primitive operations on integers *)
 
-let make_const_int n = (Uconst(Const_base(Const_int n), None), Value_integer n)
-let make_const_ptr n = (Uconst(Const_pointer n, None), Value_constptr n)
+let make_const_int n = (Uconst(Const_base(Const_int n)), Value_integer n)
+let make_const_ptr n = (Uconst(Const_pointer n), Value_constptr n)
 let make_const_bool b = make_const_ptr(if b then 1 else 0)
 
 let simplif_prim_pure p (args, approxs) dbg =
    over functions. *)
 
 let approx_ulam = function
-    Uconst(Const_base(Const_int n),_) -> Value_integer n
-  | Uconst(Const_base(Const_char c),_) -> Value_integer(Char.code c)
-  | Uconst(Const_pointer n,_) -> Value_constptr n
+    Uconst(Const_base(Const_int n)) -> Value_integer n
+  | Uconst(Const_base(Const_char c)) -> Value_integer(Char.code c)
+  | Uconst(Const_pointer n) -> Value_constptr n
   | _ -> Value_unknown
 
 let rec substitute sb ulam =
   match ulam with
     Uvar v ->
       begin try Tbl.find v sb with Not_found -> ulam end
-  | Uconst _ -> ulam
+  | Uconst cst -> ulam
   | Udirect_apply(lbl, args, dbg) ->
       Udirect_apply(lbl, List.map (substitute sb) args, dbg)
   | Ugeneric_apply(fn, args, dbg) ->
       Utrywith(substitute sb u1, id', substitute (Tbl.add id (Uvar id') sb) u2)
   | Uifthenelse(u1, u2, u3) ->
       begin match substitute sb u1 with
-        Uconst(Const_pointer n, _) ->
+        Uconst(Const_pointer n) ->
           if n <> 0 then substitute sb u2 else substitute sb u3
       | su1 ->
           Uifthenelse(su1, substitute sb u2, substitute sb u3)
 let is_simple_argument = function
     Uvar _ -> true
   | Uconst(Const_base(Const_int _ | Const_char _ | Const_float _ |
-                      Const_int32 _ | Const_int64 _ | Const_nativeint _),_) ->
+                      Const_int32 _ | Const_int64 _ | Const_nativeint _)) ->
       true
-  | Uconst(Const_pointer _, _) -> true
+  | Uconst(Const_pointer _) -> true
   | _ -> false
 
 let no_effects = function
     Uclosure _ -> true
-  | Uconst(Const_base(Const_string _),_) -> true
+  | Uconst(Const_base(Const_string _)) -> true
   | u -> is_simple_argument u
 
 let rec bind_params_rec subst params args body =
       close_approx_var fenv cenv id
   | Lconst cst ->
       begin match cst with
-        Const_base(Const_int n) -> (Uconst (cst,None), Value_integer n)
-      | Const_base(Const_char c) -> (Uconst (cst,None), Value_integer(Char.code c))
-      | Const_pointer n -> (Uconst (cst, None), Value_constptr n)
-      | _ -> (Uconst (cst, Some (Compilenv.new_structured_constant cst true)), Value_unknown)
+        Const_base(Const_int n) -> (Uconst cst, Value_integer n)
+      | Const_base(Const_char c) -> (Uconst cst, Value_integer(Char.code c))
+      | Const_pointer n -> (Uconst cst, Value_constptr n)
+      | _ -> (Uconst cst, Value_unknown)
       end
   | Lfunction(kind, params, body) as funct ->
       close_one_function fenv cenv (Ident.create "fun") funct
       | ((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

 
 (* Translate structured constants *)
 
-(* Fabrice: moved to compilenv.ml ----
 let const_label = ref 0
 
 let new_const_label () =
   Compilenv.make_symbol (Some (string_of_int !const_label))
 
 let structured_constants = ref ([] : (string * structured_constant) list)
-*)
 
 let transl_constant = function
     Const_base(Const_int n) ->
       else Cconst_natpointer
               (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n)
   | cst ->
-      Cconst_symbol (Compilenv.new_structured_constant cst false)
+      let lbl = new_const_symbol() in
+      structured_constants := (lbl, cst) :: !structured_constants;
+      Cconst_symbol lbl
 
 (* Translate constant closures *)
 
   | 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 *)
 
   | Boxed_integer of boxed_integer
 
 let is_unboxed_number = function
-    Uconst(Const_base(Const_float f), _) ->
+    Uconst(Const_base(Const_float f)) ->
       Boxed_float
   | Uprim(p, _, _) ->
       begin match simplif_primitive p with
 let rec transl = function
     Uvar id ->
       Cvar id
-  | Uconst (sc, Some const_label) ->
-      Cconst_symbol const_label
-  | Uconst (sc, None) ->
+  | Uconst sc ->
       transl_constant sc
   | Uclosure(fundecls, []) ->
-      let lbl = Compilenv.new_const_symbol() in
+      let lbl = new_const_symbol() in
       constant_closures := (lbl, fundecls) :: !constant_closures;
       List.iter
         (fun (label, arity, params, body) ->
       if no_overflow_lsl n then
         add_const (transl arg) (n lsl 1)
       else
-        transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n), None)) Debuginfo.none
+        transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n))) Debuginfo.none
   | Poffsetref n ->
       return_unit
         (bind "ref" (transl arg) (fun arg ->
     fatal_error "Cmmgen.transl_prim_3"
 
 and transl_unbox_float = function
-    Uconst(Const_base(Const_float f), _) -> Cconst_float f
+    Uconst(Const_base(Const_float f)) -> Cconst_float f
   | exp -> unbox_float(transl exp)
 
 and transl_unbox_int bi = function
-    Uconst(Const_base(Const_int32 n), _) ->
+    Uconst(Const_base(Const_int32 n)) ->
       Cconst_natint (Nativeint.of_int32 n)
-  | Uconst(Const_base(Const_nativeint n), _) ->
+  | Uconst(Const_base(Const_nativeint n)) ->
       Cconst_natint n
-  | Uconst(Const_base(Const_int64 n), _) ->
+  | Uconst(Const_base(Const_int64 n)) ->
       assert (size_int = 8); Cconst_natint (Int64.to_nativeint n)
-  | Uprim(Pbintofint bi', [Uconst(Const_base(Const_int i),_)], _) when bi = bi' ->
+  | Uprim(Pbintofint bi', [Uconst(Const_base(Const_int i))], _) when bi = bi' ->
       Cconst_int i
   | exp -> unbox_int bi (transl exp)
 
 
 and exit_if_true cond nfail otherwise =
   match cond with
-  | Uconst (Const_pointer 0, _) -> otherwise
-  | Uconst (Const_pointer 1, _) -> Cexit (nfail,[])
+  | Uconst (Const_pointer 0) -> otherwise
+  | Uconst (Const_pointer 1) -> Cexit (nfail,[])
   | Uprim(Psequor, [arg1; arg2], _) ->
       exit_if_true arg1 nfail (exit_if_true arg2 nfail otherwise)
   | Uprim(Psequand, _, _) ->
 
 and exit_if_false cond otherwise nfail =
   match cond with
-  | Uconst (Const_pointer 0, _) -> Cexit (nfail,[])
-  | Uconst (Const_pointer 1, _) -> otherwise
+  | Uconst (Const_pointer 0) -> Cexit (nfail,[])
+  | Uconst (Const_pointer 1) -> otherwise
   | Uprim(Psequand, [arg1; arg2], _) ->
       exit_if_false arg1 (exit_if_false arg2 otherwise nfail) nfail
   | Uprim(Psequor, _, _) ->
   | Const_base(Const_char c) ->
       (Cint(Nativeint.of_int(((Char.code c) lsl 1) + 1)), cont)
   | Const_base(Const_float s) ->
-      let lbl = Compilenv.new_const_label() in
+      let lbl = new_const_label() in
       (Clabel_address lbl,
        Cint(float_header) :: Cdefine_label lbl :: Cdouble s :: cont)
   | Const_base(Const_string s) ->
-      let lbl = Compilenv.new_const_label() in
+      let lbl = new_const_label() in
       (Clabel_address lbl,
        Cint(string_header (String.length s)) :: Cdefine_label lbl ::
        emit_string_constant s cont)
       begin try
         (Clabel_address (Hashtbl.find immstrings s), cont)
       with Not_found ->
-        let lbl = Compilenv.new_const_label() in
+        let lbl = new_const_label() in
         Hashtbl.add immstrings s lbl;
         (Clabel_address lbl,
          Cint(string_header (String.length s)) :: Cdefine_label lbl ::
          emit_string_constant s cont)
       end
   | Const_base(Const_int32 n) ->
-      let lbl = Compilenv.new_const_label() in
+      let lbl = new_const_label() in
       (Clabel_address lbl,
        Cint(boxedint32_header) :: Cdefine_label lbl ::
        emit_boxed_int32_constant n cont)
   | Const_base(Const_int64 n) ->
-      let lbl = Compilenv.new_const_label() in
+      let lbl = new_const_label() in
       (Clabel_address lbl,
        Cint(boxedint64_header) :: Cdefine_label lbl ::
        emit_boxed_int64_constant n cont)
   | Const_base(Const_nativeint n) ->
-      let lbl = Compilenv.new_const_label() in
+      let lbl = new_const_label() in
       (Clabel_address lbl,
        Cint(boxedintnat_header) :: Cdefine_label lbl ::
        emit_boxed_nativeint_constant n cont)
       (Cint(Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n),
        cont)
   | Const_block(tag, fields) ->
-      let lbl = Compilenv.new_const_label() in
+      let lbl = new_const_label() in
       let (emit_fields, cont1) = emit_constant_fields fields cont in
       (Clabel_address lbl,
        Cint(block_header tag (List.length fields)) :: Cdefine_label lbl ::
        emit_fields @ cont1)
   | Const_float_array(fields) ->
-      let lbl = Compilenv.new_const_label() in
+      let lbl = new_const_label() in
       (Clabel_address lbl,
        Cint(floatarray_header (List.length fields)) :: Cdefine_label lbl ::
        Misc.map_end (fun f -> Cdouble f) fields cont)
 let emit_all_constants cont =
   let c = ref cont in
   List.iter
-    (fun (lbl, global, cst) -> 
-       let cst = emit_constant lbl cst [] in
-       let cst = if global then 
-	 Cglobal_symbol lbl :: cst
-       else cst in
-	 c:= Cdata(cst):: !c)
-    (Compilenv.structured_constants());
-(*  structured_constants := []; done in Compilenv.reset() *)
+    (fun (lbl, cst) -> c := Cdata(emit_constant lbl cst []) :: !c)
+    !structured_constants;
+  structured_constants := [];
   Hashtbl.clear immstrings;   (* PR#3979 *)
   List.iter
     (fun (symb, fundecls) ->

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/compilenv.ml

 let global_infos_table =
   (Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t)
 
-let structured_constants = ref ([] : (string * bool * Lambda.structured_constant) list)
-
 let current_unit =
   { ui_name = "";
     ui_symbol = "";
       Buffer.add_string b name;
       Buffer.contents b
 
-
 let reset ?packname name =
   Hashtbl.clear global_infos_table;
   let symbol = symbolname_for_pack packname name in
   current_unit.ui_curry_fun <- [];
   current_unit.ui_apply_fun <- [];
   current_unit.ui_send_fun <- [];
-  current_unit.ui_force_link <- false;
-  structured_constants := []
+  current_unit.ui_force_link <- false
 
 let current_unit_infos () =
   current_unit
   current_unit.ui_imports_cmi <- Env.imported_units();
   write_unit_info current_unit filename
 
-
-
-let const_label = ref 0
-
-let new_const_label () =
-  incr const_label;
-  !const_label
-
-let new_const_symbol () =
-  incr const_label;
-  make_symbol (Some (string_of_int !const_label))
-
-let new_structured_constant cst global =
-  let lbl = new_const_symbol() in
-  structured_constants := (lbl, global, cst) :: !structured_constants;
-  lbl
-
-let structured_constants () = !structured_constants
-
 (* Error report *)
 
 open Format

asmcomp/compilenv.mli

         (* Record the need of a currying (resp. application,
            message sending) function with the given arity *)
 
-val new_const_symbol : unit -> string
-val new_const_label : unit -> int
-val new_structured_constant : Lambda.structured_constant -> bool -> string
-val structured_constants : unit -> (string * bool * Lambda.structured_constant) list
 
 val read_unit_info: string -> unit_infos * Digest.t
         (* Read infos and CRC from a [.cmx] file. *)

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

asmrun/.cvsignore

-// svn propset -F .cvsignore svn:ignore .
-*.p.c
-*.d.c
 libasmrun.a
 libasmrunp.a
 main.c
 DOBJS=$(COBJS:.o=.d.o) $(ASMOBJS)
 POBJS=$(COBJS:.o=.p.o) $(ASMOBJS:.o=.p.o)
 
-all: libasmrun.a all-$(RUNTIMED) all-$(PROFILING)
+all: libasmrun.a all-$(PROFILING)
 
 libasmrun.a: $(OBJS)
 	rm -f libasmrun.a
 	ar rc libasmrun.a $(OBJS)
 	$(RANLIB) libasmrun.a
 
-all-noruntimed:
-.PHONY: all-noruntimed
-
-all-runtimed: libasmrund.a
-.PHONY: all-runtimed
-
 libasmrund.a: $(DOBJS)
 	rm -f libasmrund.a
 	ar rc libasmrund.a $(DOBJS)
 	ar rc libasmrunp.a $(POBJS)
 	$(RANLIB) libasmrunp.a
 
-install: install-default install-$(RUNTIMED) install-$(PROFILING)
+install: install-default install-$(PROFILING)
 
 install-default:
 	cp libasmrun.a $(LIBDIR)/libasmrun.a
 	cd $(LIBDIR); $(RANLIB) libasmrun.a
 
-install-noruntimed:
-.PHONY: install-noruntimed
-
-install-runtimed:
-	cp libasmrund.a $(LIBDIR)/libasmrund.a
-	cd $(LIBDIR); $(RANLIB) libasmrund.a
-.PHONY: install-runtimed
-
 install-noprof:
 	rm -f $(LIBDIR)/libasmrunp.a; ln -s libasmrun.a $(LIBDIR)/libasmrunp.a
 
 	$(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $*.p.o $*.S
 
 .c.d.o:
-	ln -s -f $*.c $*.d.c
-	$(CC) -c $(DFLAGS) $*.d.c
+	@ if test -f $*.o; then mv $*.o $*.f.o; else :; fi
+	$(CC) -c $(DFLAGS) $<
+	mv $*.o $*.d.o
+	@ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi
 
 .c.p.o:
-	ln -s -f $*.c $*.p.c
-	$(CC) -c $(PFLAGS) $*.p.c
+	@ if test -f $*.o; then mv $*.o $*.f.o; else :; fi
+	$(CC) -c $(PFLAGS) $<
+	mv $*.o $*.p.o
+	@ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi
 
 .s.o:
 	$(ASPP) -DSYS_$(SYSTEM) -o $*.o $*.s
 	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
 myocamlbuild
 myocamlbuild.native
 libcamlrun.a
-*.cm*
-*.o

Binary file modified.

Binary file modified.

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/fastworld.sh

   $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
                  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 \

bytecomp/.cvsignore

 runtimedef.ml
 opcodes.ml
-*.cm*
-*.o

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

       try
         let header =
           if String.length !Clflags.use_runtime > 0
-          then "camlheader_ur" else "camlheader" ^ !Clflags.runtime_variant in
+          then "camlheader_ur" else "camlheader" in
         let inchan = open_in_bin (find_in_path !load_path header) in
         copy_file inchan outchan;
         close_in inchan
   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;
 (* Build a custom runtime *)
 
 let build_custom_runtime prim_name exec_name =
-  let runtime_lib = "-lcamlrun" ^ !Clflags.runtime_variant in
   Ccomp.call_linker Ccomp.Exe exec_name
-    ([prim_name] @ List.rev !Clflags.ccobjs @ [runtime_lib])
+    ([prim_name] @ List.rev !Clflags.ccobjs @ ["-lcamlrun"])
     (Clflags.std_include_flag "-I" ^ " " ^ Config.bytecomp_c_libraries)
 
 let append_bytecode_and_cleanup bytecode_name exec_name prim_name =
         if not (Filename.check_suffix output_name Config.ext_obj) then begin
           temps := obj_file :: !temps;
           if not (
-            let runtime_lib = "-lcamlrun" ^ !Clflags.runtime_variant in
             Ccomp.call_linker Ccomp.MainDll output_name
-              ([obj_file] @ List.rev !Clflags.ccobjs @ [runtime_lib])
+              ([obj_file] @ List.rev !Clflags.ccobjs @ ["-lcamlrun"])
               Config.bytecomp_c_libraries
            ) then raise (Error Custom_runtime);
         end

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 l
-  | Lsend(_, m, o, ll) -> List.iter count (m::o::ll)
+  | Lsend(_, m, o, ll, _) -> List.iter count (m::o::ll)
   | Levent(l, _) -> count l
   | Lifused(v, l) ->
       if count_var v > 0 then 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) ->
       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/.cvsignore

-// svn propset -F .cvsignore svn:ignore .
 jumptbl.h
 primitives
 prims.c
 *.so
 *.a
 .depend.nt
-*.d.c
-*.pic.c
 clean::
 	rm -f libcamlrun_shared.so
 
+
 .SUFFIXES: .d.o .pic.o
 
 .c.d.o:
-	ln -s -f $*.c $*.d.c
-	$(CC) -c $(DFLAGS) $*.d.c
-	rm $*.d.c
+	@ if test -f $*.o; then mv $*.o $*.f.o; else :; fi
+	$(CC) -c $(DFLAGS) $<
+	mv $*.o $*.d.o
+	@ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi
 
 .c.pic.o:
-	ln -s -f $*.c $*.pic.c
-	$(CC) -c $(CFLAGS) $(SHAREDCCCOMPOPTS) $*.pic.c
-	rm $*.pic.c
+	@ if test -f $*.o; then mv $*.o $*.f.o; else :; fi
+	$(CC) -c $(CFLAGS) $(SHAREDCCCOMPOPTS) $<
+	mv $*.o $*.pic.o
+	@ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi
 
 depend : prims.c opnames.h jumptbl.h version.h
 	-gcc -MM $(BYTECCCOMPOPTS) *.c > .depend

byterun/Makefile.common

   memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h
 
 
-all:: ocamlrun$(EXE) ld.conf libcamlrun.$(A) all-$(RUNTIMED)
+all:: ocamlrun$(EXE) ld.conf libcamlrun.$(A)
 .PHONY: all
 
-all-noruntimed:
-.PHONY: all-noruntimed
-
-all-runtimed: ocamlrund$(EXE) libcamlrund.$(A)
-.PHONY: all-runtimed
-
 ld.conf: ../config/Makefile
 	echo "$(STUBLIBDIR)" > ld.conf
 	echo "$(LIBDIR)" >> ld.conf
 	cp ld.conf $(LIBDIR)/ld.conf
 .PHONY: install
 
-install:: install-$(RUNTIMED)
-
-install-noruntimed:
-.PHONY: install-noruntimed
-
-install-runtimed:
-	cp ocamlrund$(EXE) $(BINDIR)/ocamlrund$(EXE)
-	cp libcamlrund.$(A) $(LIBDIR)/libcamlrund.$(A)
-.PHONY: install-runtimed
 
 primitives : $(PRIMS)
 	sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" \
 #include "misc.h"
 #include "mlvalues.h"
 
-CAMLexport mlsize_t caml_array_length(value array){
-  tag_t tag = Tag_val(array);
-  if (tag == Double_array_tag)
-    return Wosize_val(array) / Double_wosize;
-  else return Wosize_val(array);
-}
-
-CAMLexport int caml_is_double_array(value array){
-  return (Tag_val(array) == Double_array_tag);
-}
-
 CAMLprim value caml_array_get_addr(value array, value index)
 {
   intnat idx = Long_val(index);
 
 /* 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);
 

byterun/mlvalues.h

   double caml__temp_d = (d); \
   Store_double_val((value)((double *) (v) + caml__temp_i), caml__temp_d); \
 }while(0)
-CAMLextern mlsize_t caml_array_length (value);   /* size in items */
-CAMLextern int caml_is_double_array (value);   /* 0 is false, 1 is true */
-
 
 /* Custom blocks.  They contain a pointer to a "method suite"
    of functions (for finalization, comparison, hashing, etc)
 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) {

camlp4/Camlp4/Camlp4Ast.partial.ml

<