Utilisation de check_urgent_gc

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

7 files changed, 23 insertions, 4 deletions

diff --git a/byterun/alloc.c b/byterun/alloc.c
index e7bf157b1..ace6f6635 100644
--- a/byterun/alloc.c
+++ b/byterun/alloc.c
@@ -54,6 +54,7 @@ value alloc_string (len)
     Alloc_small (result, wosize, String_tag);
   }else{
     result = alloc_shr (wosize, String_tag);
+    result = check_urgent_gc (result);
   }
   Field (result, wosize - 1) = 0;
   offset_index = Bsize_wsize (wosize) - 1;
@@ -70,6 +71,7 @@ value alloc_final (len, fun, mem, max)
 
   Field (result, 0) = (value) fun;
   adjust_gc_speed (mem, max);
+  result = check_urgent_gc (result);
   return result;
 }
 
diff --git a/byterun/array.c b/byterun/array.c
index e6b191aff..4f38fbc6b 100644
--- a/byterun/array.c
+++ b/byterun/array.c
@@ -63,12 +63,14 @@ value make_vect(len, init)      /* ML */
     res = alloc_shr(size, 0);
     init = root[0];
     for (i = 0; i < size; i++) Field(res, i) = init;
+    res = check_urgent_gc (res);
   }
   else {
     root[0] = init;
     res = alloc_shr(size, 0);
     init = root[0];
     for (i = 0; i < size; i++) initialize(&Field(res, i), init);
+    res = check_urgent_gc (res);
   }
   Pop_roots();
   return res;
diff --git a/byterun/intern.c b/byterun/intern.c
index 895e1aade..8b0435a7d 100644
--- a/byterun/intern.c
+++ b/byterun/intern.c
@@ -220,10 +220,12 @@ static void intern_alloc(whsize, num_objects)
   } else {
     wosize = Wosize_whsize(whsize);
     if (wosize > Max_wosize) failwith("intern: structure too big");
-    if (wosize < Max_young_wosize)
+    if (wosize < Max_young_wosize) {
       intern_block = alloc(wosize, String_tag);
-    else
+    } else {
       intern_block = alloc_shr(wosize, String_tag);
+      intern_block = check_urgent_gc (intern_block);
+    }
     intern_header = Hd_val(intern_block);
     intern_color = Color_hd(intern_header);
     Assert (intern_color == White || intern_color == Black);
diff --git a/byterun/interp.c b/byterun/interp.c
index 530a4dbc2..20c79add2 100644
--- a/byterun/interp.c
+++ b/byterun/interp.c
@@ -691,7 +691,6 @@ value interprete(prog, prog_size)
     process_signal:
       something_to_do = 0;
       if (force_major_slice){
-	force_major_slice = 0;
 	Setup_for_gc;
 	minor_collection ();
 	Restore_after_gc;
diff --git a/byterun/memory.h b/byterun/memory.h
index 9c06d1080..252873e57 100644
--- a/byterun/memory.h
+++ b/byterun/memory.h
@@ -28,6 +28,7 @@ value alloc_shr P((mlsize_t, tag_t));
 void adjust_gc_speed P((mlsize_t, mlsize_t));
 void modify P((value *, value));
 void initialize P((value *, value));
+value check_urgent_gc P((value));
 char * stat_alloc P((asize_t));	             /* Size in bytes. */
 void stat_free P((char *));
 char * stat_resize P((char *, asize_t));     /* Size in bytes. */
diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c
index 7b85f9a30..553ec65b3 100644
--- a/byterun/minor_gc.c
+++ b/byterun/minor_gc.c
@@ -142,6 +142,19 @@ void minor_collection ()
   force_major_slice = 0;
 }
 
+value check_urgent_gc (extra_root)
+     value extra_root;
+{
+  if (force_major_slice) {
+    Push_roots(r, 1);
+    r[0] = extra_root;
+    minor_collection();
+    extra_root = r[0];
+    Pop_roots();
+  }
+  return extra_root;
+}
+
 void realloc_ref_table ()
 {                                 Assert (ref_table_ptr == ref_table_limit);
                                   Assert (ref_table_limit <= ref_table_end);
diff --git a/otherlibs/num/nat_stubs.c b/otherlibs/num/nat_stubs.c
index 249f11e79..55b2947c0 100644
--- a/otherlibs/num/nat_stubs.c
+++ b/otherlibs/num/nat_stubs.c
@@ -29,7 +29,7 @@ value create_nat(size)	/* ML */
   if (sz < Max_young_wosize) {
     return alloc(sz, Nat_tag);
   } else {
-    return alloc_shr(sz, Nat_tag);
+    return check_urgent_gc(alloc_shr(sz, Nat_tag));
   }
 }