Merge tag 4.03.0 into trunk.

Author: damiendoligez

Changes

@@ -382,13 +382,15 @@ Runtime system:
 - GPR#262: Multiple GC roots per compilation unit
   (Pierre Chambart, Mark Shinwell, review by Damien Doligez)
 
-- GPR#297: Several changes to improve the worst-case GC pause time.
-  (Damien Doligez, with help from Leo White and Francois Bobot)
+* GPR#297: Several changes to improve the worst-case GC pause time.
+  Changes Gc.control and Gc.major_slice and adds functions to the Gc module.
+  (Damien Doligez, with help from Francois Bobot, Thomas Braibant, Leo White)
 
 - GPR#325: Add v=0x400 flag to OCAMLRUNPARAM to display GC stats on exit
   (Louis Gesbert, review by Alain Frisch)
 
 Standard library:
+=================
 
 - PR#1460, GPR#230: Array.map2, Array.iter2
   (John Christopher McAlpine)
@@ -610,6 +612,10 @@ Other libraries:
     "end of line" means for "^" and "$" regexps.
   (Xavier Leroy, question by Fredrik Lindgren)
 
+- PR#7209: do not run at_exit handlers in [Unix.create_process] and
+  similar functions when the [exec] call fails in the child process
+  (Jérémie Dimino)
+
 OCamldep:
 =========
 
@@ -630,6 +636,9 @@ Manual:
 - PR#6676: ongoing simplification of the "Language Extensions" section
   (Alain Frisch, John Whitington)
 
+- PR#6898: Update win32 support documentation of the Unix library
+  (Damien Doligez, report by Daniel Bünzli)
+
 - PR#7092, GPR#379: Add missing documentation for new 4.03 features
   (Florian Angeletti)
 
@@ -748,7 +757,7 @@ Bug fixes:
 - PR#6805: Duplicated expression in case of hole in a non-failing switch.
   (Luc Maranget)
 
-- PR#6808: the parsing of OCAMLRUNPARAM is too lax
+* PR#6808: the parsing of OCAMLRUNPARAM is too lax
   (Damien Doligez)
 
 - PR#6874: Inefficient code generated for module function arguments
@@ -882,9 +891,15 @@ Bug fixes:
 - PR#7160: Type synonym definitions can weaken gadt constructor types
   (Jacques Garrigue, report by Mikhail Mandrykin)
 
+- PR#7181: Misleading error message with GADTs and polymorphic variants
+  (Jacques Garrigue, report by Pierre Chambart)
+
 - PR#7182: Assertion failure with recursive modules and externals
   (Jacques Garrigue, report by Jeremy Yallop)
 
+- PR#7196: "let open" is not correctly pretty-printed to the left of a ';'
+  (Gabriel Scherer, report by Christophe Raffalli)
+
 - PR#7214: Assertion failure in Env.add_gadt_instances
   (Jacques Garrigue, report by Stephen Dolan)
 
@@ -1074,6 +1089,11 @@ Features wishes:
   GNU parallel tool to run tests in parallel.
   (Gabriel Scherer)
 
+- GPR#555: ensure that register typing constraints are respected at
+  join points in the control flow graph
+  (Mark Shinwell, debugging & test case by Arseniy Alekseyev and Leo White,
+    code review by Xavier Leroy)
+
 Build system:
 =============
 

VERSION

@@ -1,4 +1,4 @@
-4.04.0+dev1-2016-04-18
+4.04.0+dev2-2016-04-27
 
 # The version string is the first line of this file.
 # It must be in the format described in stdlib/sys.mli

asmcomp/cmm.ml

@@ -32,6 +32,56 @@ let size_component = function
   | Int -> Arch.size_int
   | Float -> Arch.size_float
 
+(** [machtype_component]s are partially ordered as follows:
+
+      Addr     Float
+       ^
+       |
+      Val
+       ^
+       |
+      Int
+
+  In particular, [Addr] must be above [Val], to ensure that if there is
+  a join point between a code path yielding [Addr] and one yielding [Val]
+  then the result is treated as a derived pointer into the heap (i.e. [Addr]).
+  (Such a result may not be live across any call site or a fatal compiler
+  error will result.)
+*)
+
+let lub_component comp1 comp2 =
+  match comp1, comp2 with
+  | Int, Int -> Int
+  | Int, Val -> Val
+  | Int, Addr -> Addr
+  | Val, Int -> Val
+  | Val, Val -> Val
+  | Val, Addr -> Addr
+  | Addr, Int -> Addr
+  | Addr, Addr -> Addr
+  | Addr, Val -> Addr
+  | Float, Float -> Float
+  | (Int | Addr | Val), Float
+  | Float, (Int | Addr | Val) ->
+    (* Float unboxing code must be sure to avoid this case. *)
+    assert false
+
+let ge_component comp1 comp2 =
+  match comp1, comp2 with
+  | Int, Int -> true
+  | Int, Addr -> false
+  | Int, Val -> false
+  | Val, Int -> true
+  | Val, Val -> true
+  | Val, Addr -> false
+  | Addr, Int -> true
+  | Addr, Addr -> true
+  | Addr, Val -> true
+  | Float, Float -> true
+  | (Int | Addr | Val), Float
+  | Float, (Int | Addr | Val) ->
+    assert false
+
 let size_machtype mty =
   let size = ref 0 in
   for i = 0 to Array.length mty - 1 do

asmcomp/cmm.mli

@@ -56,6 +56,20 @@ val typ_int: machtype
 val typ_float: machtype
 
 val size_component: machtype_component -> int
+
+(** Least upper bound of two [machtype_component]s. *)
+val lub_component
+   : machtype_component
+  -> machtype_component
+  -> machtype_component
+
+(** Returns [true] iff the first supplied [machtype_component] is greater than
+    or equal to the second under the relation used by [lub_component]. *)
+val ge_component
+   : machtype_component
+  -> machtype_component
+  -> bool
+
 val size_machtype: machtype -> int
 
 type comparison =

asmcomp/selectgen.ml

@@ -117,14 +117,19 @@ let join opt_r1 seq1 opt_r2 seq2 =
       assert (l1 = Array.length r2);
       let r = Array.make l1 Reg.dummy in
       for i = 0 to l1-1 do
-        if Reg.anonymous r1.(i) then begin
+        if Reg.anonymous r1.(i)
+          && Cmm.ge_component r1.(i).typ r2.(i).typ
+        then begin
           r.(i) <- r1.(i);
           seq2#insert_move r2.(i) r1.(i)
-        end else if Reg.anonymous r2.(i) then begin
+        end else if Reg.anonymous r2.(i)
+          && Cmm.ge_component r2.(i).typ r1.(i).typ
+        then begin
           r.(i) <- r2.(i);
           seq1#insert_move r1.(i) r2.(i)
         end else begin
-          r.(i) <- Reg.create r1.(i).typ;
+          let typ = Cmm.lub_component r1.(i).typ r2.(i).typ in
+          r.(i) <- Reg.create typ;
           seq1#insert_move r1.(i) r.(i);
           seq2#insert_move r2.(i) r.(i)
         end

bytecomp/translmod.ml

@@ -557,21 +557,26 @@ let scan_used_globals lam =
   in
   scan lam; !globals
 
-let wrap_globals body =
+let wrap_globals ~flambda body =
   let globals = scan_used_globals body in
   let add_global id req =
-    if IdentSet.mem id globals then req else IdentSet.add id req in
+    if not flambda && IdentSet.mem id globals then
+      req
+    else
+      IdentSet.add id req
+  in
   let required =
-    Hashtbl.fold (fun path _ -> add_global (Path.head path))
-      used_primitives IdentSet.empty
+    Hashtbl.fold
+      (fun path _ -> add_global (Path.head path)) used_primitives
+      (if flambda then globals else IdentSet.empty)
   in
   let required =
     List.fold_right add_global (Env.get_required_globals ()) required
   in
   Env.reset_required_globals ();
   Hashtbl.clear used_primitives;
   IdentSet.fold
-    (fun id expr -> Lsequence(Lprim(Pgetglobal id, []), expr))
+    (fun id expr -> Lsequence(Lprim(Popaque, [Lprim(Pgetglobal id, [])]), expr))
     required body
   (* Location.prerr_warning loc
         (Warnings.Nonrequired_global (Ident.name (Path.head path),
@@ -589,7 +594,7 @@ let transl_implementation_flambda module_name (str, cc) =
     Translobj.transl_label_init
       (fun () -> transl_struct [] cc (global_path module_id) str)
   in
-  (module_id, size), wrap_globals body
+  (module_id, size), wrap_globals ~flambda:true body
 
 let transl_implementation module_name (str, cc) =
   let (module_id, _size), module_initializer =
@@ -944,7 +949,7 @@ let transl_store_implementation module_name (str, restr) =
   let (i, r) = transl_store_gen module_name (str, restr) false in
   transl_store_subst := s;
   { Lambda.main_module_block_size = i;
-    code = wrap_globals r; }
+    code = wrap_globals ~flambda:false r; }
 
 (* Compile a toplevel phrase *)
 

byterun/caml/minor_gc.h

@@ -38,7 +38,7 @@ extern int caml_in_minor_collection;
 }
 
 struct caml_ref_table CAML_TABLE_STRUCT(value *);
-CAMLextern struct caml_ref_table caml_ref_table, caml_finalize_table;
+CAMLextern struct caml_ref_table caml_ref_table;
 
 struct caml_ephe_ref_elt {
   value ephe;      /* an ephemeron in major heap */
@@ -48,6 +48,15 @@ struct caml_ephe_ref_elt {
 struct caml_ephe_ref_table CAML_TABLE_STRUCT(struct caml_ephe_ref_elt);
 CAMLextern struct caml_ephe_ref_table caml_ephe_ref_table;
 
+struct caml_custom_elt {
+  value block;     /* The finalized block in the minor heap. */
+  mlsize_t mem;    /* The parameters for adjusting GC speed. */
+  mlsize_t max;
+};
+
+struct caml_custom_table CAML_TABLE_STRUCT(struct caml_custom_elt);
+CAMLextern struct caml_custom_table caml_custom_table;
+
 extern void caml_set_minor_heap_size (asize_t); /* size in bytes */
 extern void caml_empty_minor_heap (void);
 CAMLextern void caml_gc_dispatch (void);
@@ -57,6 +66,9 @@ extern void caml_alloc_table (struct caml_ref_table *, asize_t, asize_t);
 extern void caml_realloc_ephe_ref_table (struct caml_ephe_ref_table *);
 extern void caml_alloc_ephe_table (struct caml_ephe_ref_table *,
                                    asize_t, asize_t);
+extern void caml_realloc_custom_table (struct caml_custom_table *);
+extern void caml_alloc_custom_table (struct caml_custom_table *,
+                                     asize_t, asize_t);
 extern void caml_oldify_one (value, value *);
 extern void caml_oldify_mopup (void);
 
@@ -90,4 +102,18 @@ static inline void add_to_ephe_ref_table (struct caml_ephe_ref_table *tbl,
   Assert(ephe_ref->offset < Wosize_val(ephe_ref->ephe));
 }
 
+static inline void add_to_custom_table (struct caml_custom_table *tbl, value v,
+                                        mlsize_t mem, mlsize_t max)
+{
+  struct caml_custom_elt *elt;
+  if (tbl->ptr >= tbl->limit){
+    CAMLassert (tbl->ptr == tbl->limit);
+    caml_realloc_custom_table (tbl);
+  }
+  elt = tbl->ptr++;
+  elt->block = v;
+  elt->mem = mem;
+  elt->max = max;
+}
+
 #endif /* CAML_MINOR_GC_H */

byterun/compact.c

@@ -405,6 +405,7 @@ void caml_compact_heap (void)
   CAMLassert (caml_young_ptr == caml_young_alloc_end);
   CAMLassert (caml_ref_table.ptr == caml_ref_table.base);
   CAMLassert (caml_ephe_ref_table.ptr == caml_ephe_ref_table.base);
+  CAMLassert (caml_custom_table.ptr == caml_custom_table.base);
 
   do_compaction ();
   CAML_INSTR_TIME (tmr, "compact/main");

byterun/custom.c

@@ -34,13 +34,9 @@ CAMLexport value caml_alloc_custom(struct custom_operations * ops,
   if (wosize <= Max_young_wosize) {
     result = caml_alloc_small(wosize, Custom_tag);
     Custom_ops_val(result) = ops;
-    if (ops->finalize != NULL) {
-      /* Remembered that the block has a finalizer */
-      if (caml_finalize_table.ptr >= caml_finalize_table.limit){
-        CAMLassert (caml_finalize_table.ptr == caml_finalize_table.limit);
-        caml_realloc_ref_table (&caml_finalize_table);
-      }
-      *caml_finalize_table.ptr++ = (value *)result;
+    if (ops->finalize != NULL || mem != 0) {
+      /* Remember that the block needs processing after minor GC. */
+      add_to_custom_table (&caml_custom_table, result, mem, max);
     }
   } else {
     result = caml_alloc_shr(wosize, Custom_tag);

byterun/gc_ctrl.c

@@ -501,7 +501,6 @@ CAMLprim value caml_gc_major_slice (value v)
 {
   CAML_INSTR_SETUP (tmr, "");
   Assert (Is_long (v));
-  caml_empty_minor_heap ();
   caml_major_collection_slice (Long_val (v));
   CAML_INSTR_TIME (tmr, "explicit/gc_major_slice");
   return Val_long (0);

byterun/intern.c

@@ -531,12 +531,8 @@ static void intern_rec(value *dest)
         Custom_ops_val(v) = ops;
 
         if (ops->finalize != NULL && Is_young(v)) {
-          /* Remembered that the block has a finalizer */
-          if (caml_finalize_table.ptr >= caml_finalize_table.limit){
-            CAMLassert (caml_finalize_table.ptr == caml_finalize_table.limit);
-            caml_realloc_ref_table (&caml_finalize_table);
-          }
-          *caml_finalize_table.ptr++ = (value *)v;
+          /* Remember that the block has a finalizer. */
+          add_to_custom_table (&caml_custom_table, v, 0, 1);
         }
 
         intern_dest += 1 + size;

byterun/major_gc.c

@@ -28,6 +28,7 @@
 #include "caml/misc.h"
 #include "caml/mlvalues.h"
 #include "caml/roots.h"
+#include "caml/signals.h"
 #include "caml/weak.h"
 
 #if defined (NATIVE_CODE) && defined (NO_NAKED_POINTERS)
@@ -568,6 +569,7 @@ static void sweep_slice (intnat work)
         ++ caml_stat_major_collections;
         work = 0;
         caml_gc_phase = Phase_idle;
+        caml_request_minor_gc ();
       }else{
         caml_gc_sweep_hp = chunk;
         limit = chunk + Chunk_size (chunk);
@@ -753,7 +755,7 @@ void caml_major_collection_slice (intnat howmuch)
   }
 
   if (caml_gc_phase == Phase_mark || caml_gc_phase == Phase_clean){
-    computed_work = (intnat) (p * (caml_stat_heap_wsz * 250
+    computed_work = (intnat) (p * ((double) caml_stat_heap_wsz * 250
                                    / (100 + caml_percent_free)
                                    + caml_incremental_roots_count));
   }else{