PR#1495

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

12 files changed, 66 insertions, 28 deletions

diff --git a/boot/ocamlc b/boot/ocamlc
index 07bd31a3c..6ee0ecd12 100755
--- a/boot/ocamlc
+++ b/boot/ocamlc
diff --git a/boot/ocamllex b/boot/ocamllex
index 22f6f0e43..f357fb26f 100755
--- a/boot/ocamllex
+++ b/boot/ocamllex
diff --git a/byterun/compact.c b/byterun/compact.c
index 5115fc77a..be49ceb65 100644
--- a/byterun/compact.c
+++ b/byterun/compact.c
@@ -381,10 +381,8 @@ void compact_heap (void)
     fl_reset ();
     while (ch != NULL){
       if (Chunk_size (ch) > Chunk_alloc (ch)){
-        header_t *p = (header_t *) (ch + Chunk_alloc (ch));
-        *p = Make_header (Wosize_bhsize (Chunk_size (ch) - Chunk_alloc (ch)),
-                          0, Caml_white);
-        fl_merge_block (Bp_hp (p));
+        make_free_blocks ((value *) (ch + Chunk_alloc (ch)),
+                          Wsize_bsize (Chunk_size (ch) - Chunk_alloc (ch)), 1);
       }
       ch = Chunk_next (ch);
     }
diff --git a/byterun/freelist.c b/byterun/freelist.c
index be6c697cd..9b43f9ae4 100644
--- a/byterun/freelist.c
+++ b/byterun/freelist.c
@@ -172,6 +172,7 @@ char *fl_merge_block (char *bp)
 {
   char *prev, *cur, *adj;
   header_t hd = Hd_bp (bp);
+  mlsize_t prev_wosz;
 
   fl_cur_size += Whsize_hd (hd);
   
@@ -192,10 +193,13 @@ char *fl_merge_block (char *bp)
 
   /* If [last_fragment] and [bp] are adjacent, merge them. */
   if (last_fragment == Hp_bp (bp)){
-    hd = Make_header (Whsize_bp (bp), 0, Caml_white);
-    bp = last_fragment;
-    Hd_bp (bp) = hd;
-    fl_cur_size += Whsize_wosize (0);
+    mlsize_t bp_whsz = Whsize_bp (bp);
+    if (bp_whsz <= Max_wosize){
+      hd = Make_header (bp_whsz, 0, Caml_white);
+      bp = last_fragment;
+      Hd_bp (bp) = hd;
+      fl_cur_size += Whsize_wosize (0);
+    }
   }
 
   /* If [bp] and [cur] are adjacent, remove [cur] from the free-list
@@ -203,24 +207,28 @@ char *fl_merge_block (char *bp)
   adj = bp + Bosize_hd (hd);
   if (adj == Hp_bp (cur)){
     char *next_cur = Next (cur);
-    long cur_whsz = Whsize_bp (cur);
+    mlsize_t cur_whsz = Whsize_bp (cur);
 
-    Next (prev) = next_cur;
-    if (fl_prev == cur) fl_prev = prev;
-    hd = Make_header (Wosize_hd (hd) + cur_whsz, 0, Caml_blue);
-    Hd_bp (bp) = hd;
-    adj = bp + Bosize_hd (hd);
+    if (Wosize_hd (hd) + cur_whsz <= Max_wosize){
+      Next (prev) = next_cur;
+      if (fl_prev == cur) fl_prev = prev;
+      hd = Make_header (Wosize_hd (hd) + cur_whsz, 0, Caml_blue);
+      Hd_bp (bp) = hd;
+      adj = bp + Bosize_hd (hd);
 #ifdef DEBUG
-    fl_last = NULL;
-    Next (cur) = (char *) Debug_free_major;
-    Hd_bp (cur) = Debug_free_major;
+      fl_last = NULL;
+      Next (cur) = (char *) Debug_free_major;
+      Hd_bp (cur) = Debug_free_major;
 #endif
-    cur = next_cur;
+      cur = next_cur;
+    }
   }
   /* If [prev] and [bp] are adjacent merge them, else insert [bp] into
      the free-list if it is big enough. */
-  if (prev + Bosize_bp (prev) == Hp_bp (bp)){
-    Hd_bp (prev) = Make_header (Wosize_bp (prev) + Whsize_hd (hd), 0,Caml_blue);
+  prev_wosz = Wosize_bp (prev);
+  if (prev + Bsize_wsize (prev_wosz) == Hp_bp (bp)
+      && prev_wosz + Whsize_hd (hd) < Max_wosize){
+    Hd_bp (prev) = Make_header (prev_wosz + Whsize_hd (hd), 0,Caml_blue);
 #ifdef DEBUG
     Hd_bp (bp) = Debug_free_major;
 #endif
@@ -282,3 +290,27 @@ void fl_add_block (char *bp)
     if (prev == fl_merge && bp <= gc_sweep_hp) fl_merge = bp;
   }
 }
+
+/* Cut a block of memory into Max_wosize pieces, give them headers,
+   and optionally merge them into the free list.
+   arguments:
+   p: pointer to the first word of the block
+   size: size of the block (in words)
+   do_merge: 1 -> do merge; 0 -> do not merge
+*/
+void make_free_blocks (value *p, mlsize_t size, int do_merge)
+{
+  mlsize_t sz;
+
+  while (size > 0){
+    if (size > Whsize_wosize (Max_wosize)){
+      sz = Whsize_wosize (Max_wosize);
+    }else{
+      sz = size;
+    }
+    *(header_t *)p = Make_header (Wosize_whsize (sz), 0, Caml_white);
+    if (do_merge) fl_merge_block (Bp_hp (p));
+    size -= sz;
+    p += sz;
+  }
+}
diff --git a/byterun/freelist.h b/byterun/freelist.h
index e306b2ba4..e121512c3 100644
--- a/byterun/freelist.h
+++ b/byterun/freelist.h
@@ -29,6 +29,7 @@ void fl_init_merge (void);
 void fl_reset (void);
 char *fl_merge_block (char *);
 void fl_add_block (char *);
+void make_free_blocks (value *, mlsize_t, int);
 
 
 #endif /* _freelist_ */
diff --git a/byterun/gc.h b/byterun/gc.h
index 43f5fa57c..627973a9d 100644
--- a/byterun/gc.h
+++ b/byterun/gc.h
@@ -40,9 +40,11 @@
 
 /* This depends on the layout of the header.  See [mlvalues.h]. */
 #define Make_header(wosize, tag, color)                                       \
+      (Assert ((wosize) <= Max_wosize),                                       \
        ((header_t) (((header_t) (wosize) << 10)                               \
                     + (color)                                                 \
-                    + (tag_t) (tag)))
+                    + (tag_t) (tag)))                                         \
+      )
 
 #define Is_white_val(val) (Color_val(val) == Caml_white)
 #define Is_gray_val(val) (Color_val(val) == Caml_gray)
diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c
index 8e9ee6daa..090cd71d3 100644
--- a/byterun/gc_ctrl.c
+++ b/byterun/gc_ctrl.c
@@ -182,13 +182,16 @@ static value heap_stats (int returnstats)
         if (Whsize_hd (cur_hd) > largest_free){
           largest_free = Whsize_hd (cur_hd);
         }
+        /* not true any more with big heap chunks
         Assert (prev_hp == NULL
                 || (Color_hp (prev_hp) != Caml_blue && Wosize_hp (prev_hp) > 0)
                 || cur_hp == gc_sweep_hp);
         Assert (Next (cur_hp) == chunk_end
                 || (Color_hp (Next (cur_hp)) != Caml_blue
                     && Wosize_hp (Next (cur_hp)) > 0)
+                || (Whsize_hd (cur_hd) + Wosize_hp (Next (cur_hp)) > Max_wosize)
                 || Next (cur_hp) == gc_sweep_hp);
+        */
         break;
       }
       prev_hp = cur_hp;
diff --git a/byterun/intern.c b/byterun/intern.c
index 8072dfe48..6be11e92e 100644
--- a/byterun/intern.c
+++ b/byterun/intern.c
@@ -372,12 +372,13 @@ static void intern_add_to_heap(mlsize_t whsize)
     /* If heap chunk not filled totally, build free block at end */
     asize_t request =
       ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log;
-    header_t * end_extra_block = 
+    header_t * end_extra_block =
       (header_t *) intern_extra_block + Wsize_bsize(request);
     Assert(intern_dest <= end_extra_block);
-    if (intern_dest < end_extra_block)
-      *intern_dest =
-        Make_header(Wosize_whsize(end_extra_block-intern_dest), 0, Caml_white);
+    if (intern_dest < end_extra_block){
+      make_free_blocks ((value *) intern_dest, end_extra_block - intern_dest,
+                        0);
+    }
     add_to_heap(intern_extra_block);
   }
 }
diff --git a/byterun/major_gc.c b/byterun/major_gc.c
index cfafeff31..bbe70a20a 100644
--- a/byterun/major_gc.c
+++ b/byterun/major_gc.c
@@ -446,9 +446,8 @@ void init_major_heap (asize_t heap_size)
     page_table [i] = In_heap;
   }
 
-  Hd_hp (heap_start) = Make_header (Wosize_bhsize(stat_heap_size),0,Caml_blue);
   fl_init_merge ();
-  fl_merge_block (Bp_hp (heap_start));
+  make_free_blocks ((value *) heap_start, Wsize_bsize (stat_heap_size), 1);
   gc_phase = Phase_idle;
   gray_vals_size = 2048;
   gray_vals = (value *) malloc (gray_vals_size * sizeof (value));
diff --git a/byterun/memory.c b/byterun/memory.c
index 5587c1e45..82773b6ea 100644
--- a/byterun/memory.c
+++ b/byterun/memory.c
@@ -159,6 +159,7 @@ int add_to_heap (char *m)
 /* Allocate more memory from malloc for the heap.
    Return a blue block of at least the requested size (in words).
    The caller must insert the block into the free list.
+   The request must be less than or equal to Max_wosize.
    Return NULL when out of memory.
 */
 static char *expand_heap (mlsize_t request)
diff --git a/byterun/memory.h b/byterun/memory.h
index d97547e3c..a28741ee3 100644
--- a/byterun/memory.h
+++ b/byterun/memory.h
@@ -58,6 +58,7 @@ color_t allocation_color (void *hp);
 
 #define Alloc_small(result, wosize, tag) do{      CAMLassert (wosize >= 1); \
                                             CAMLassert ((tag_t) tag < 256); \
+                                 CAMLassert ((wosize) <= Max_young_wosize); \
   young_ptr -= Bhsize_wosize (wosize);                                      \
   if (young_ptr < young_limit){                                             \
     young_ptr += Bhsize_wosize (wosize);                                    \
diff --git a/stdlib/sys.ml b/stdlib/sys.ml
index 7099fa2f1..66960d49c 100644
--- a/stdlib/sys.ml
+++ b/stdlib/sys.ml
@@ -77,4 +77,4 @@ let catch_break on =
 
 (* OCaml version string, must be in the format described in sys.mli. *)
 
-let ocaml_version = "3.06+19 (2002-12-03)";;
+let ocaml_version = "3.06+20 (2002-12-12)";;