changement gc_message

alloc_for_heap, add_to_heap, allocation_color
mauvais parametres alloc_final dans io.c


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

13 files changed, 225 insertions, 147 deletions

diff --git a/byterun/compact.c b/byterun/compact.c
index 480dd5b94..eb5d65991 100644
--- a/byterun/compact.c
+++ b/byterun/compact.c
@@ -137,7 +137,7 @@ void compact_heap (void)
 {
   char *ch, *chend;
                                                Assert (gc_phase == Phase_idle);
-  gc_message ("Compacting heap...\n", 0);
+  gc_message (0x10, "Compacting heap...\n", 0);
   /* First pass: encode all noninfix headers. */
   {
     ch = heap_start;
@@ -373,7 +373,7 @@ void compact_heap (void)
     }
   }
   ++ stat_compactions;
-  gc_message ("done.\n", 0);
+  gc_message (0x10, "done.\n", 0);
 }
 
 unsigned long percent_max;
diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c
index 49b8bf275..caff3346d 100644
--- a/byterun/gc_ctrl.c
+++ b/byterun/gc_ctrl.c
@@ -130,13 +130,13 @@ value gc_get(value v) /* ML */
 
   Assert (v == Val_unit);
   res = alloc (6, 0);
-  Field (res, 0) = Wsize_bsize (Val_long (minor_heap_size));
-  Field (res, 1) = Wsize_bsize (Val_long (major_heap_increment));
-  Field (res, 2) = Val_long (percent_free);
-  Field (res, 3) = Val_bool (verb_gc);
-  Field (res, 4) = Val_long (percent_max);
+  Field (res, 0) = Wsize_bsize (Val_long (minor_heap_size));        /* s */
+  Field (res, 1) = Wsize_bsize (Val_long (major_heap_increment));   /* i */
+  Field (res, 2) = Val_long (percent_free);                         /* o */
+  Field (res, 3) = Val_long (verb_gc);                              /* v */
+  Field (res, 4) = Val_long (percent_max);                          /* O */
 #ifndef NATIVE_CODE
-  Field (res, 5) = Val_long (max_stack_size);
+  Field (res, 5) = Val_long (max_stack_size);                       /* l */
 #else
   Field (res, 5) = 0;
 #endif
@@ -177,7 +177,7 @@ value gc_set(value v) /* ML */
   asize_t newheapincr;
   asize_t newminsize;
 
-  verb_gc = Bool_val (Field (v, 3));
+  verb_gc = Long_val (Field (v, 3));
 
 #ifndef NATIVE_CODE
   change_max_stack_size (Long_val (Field (v, 5)));
@@ -186,19 +186,19 @@ value gc_set(value v) /* ML */
   newpf = norm_pfree (Long_val (Field (v, 2)));
   if (newpf != percent_free){
     percent_free = newpf;
-    gc_message ("New space overhead: %d%%\n", percent_free);
+    gc_message (0x20, "New space overhead: %d%%\n", percent_free);
   }
 
   newpm = norm_pmax (Long_val (Field (v, 4)));
   if (newpm != percent_max){
     percent_max = newpm;
-    gc_message ("New max overhead: %d%%\n", percent_max);
+    gc_message (0x20, "New max overhead: %d%%\n", percent_max);
   }
 
   newheapincr = norm_heapincr (Bsize_wsize (Long_val (Field (v, 1))));
   if (newheapincr != major_heap_increment){
     major_heap_increment = newheapincr;
-    gc_message ("New heap increment size: %luk bytes\n",
+    gc_message (0x20, "New heap increment size: %luk bytes\n",
                 major_heap_increment/1024);
   }
 
@@ -206,7 +206,7 @@ value gc_set(value v) /* ML */
        (thus invalidating [v]) and it can raise [Out_of_memory]. */
   newminsize = norm_minsize (Bsize_wsize (Long_val (Field (v, 0))));
   if (newminsize != minor_heap_size){
-    gc_message ("New minor heap size: %luk bytes\n", newminsize/1024);
+    gc_message (0x20, "New minor heap size: %luk bytes\n", newminsize/1024);
     set_minor_heap_size (newminsize);
   }
   return Val_unit;
@@ -242,12 +242,14 @@ value gc_compaction(value v) /* ML */
   return Val_unit;
 }
 
-void init_gc (long unsigned int minor_size, long unsigned int major_size, long unsigned int major_incr, long unsigned int percent_fr, long unsigned int percent_m, long unsigned int verb)
+void init_gc (unsigned long minor_size, unsigned long major_size,
+              unsigned long major_incr, unsigned long percent_fr,
+              unsigned long percent_m,  unsigned long verb)
 {
   unsigned long major_heap_size = Bsize_wsize (norm_heapincr (major_size));
 #ifdef DEBUG
-  verb_gc = 1;
-  gc_message ("*** O'Caml runtime: debug mode ***\n", 0);
+  verb_gc = 0xFFF;
+  gc_message (0xFFF, "*** O'Caml runtime: debug mode ***\n", 0);
 #endif
   verb_gc = verb;
   set_minor_heap_size (Bsize_wsize (norm_minsize (minor_size)));
@@ -255,10 +257,12 @@ void init_gc (long unsigned int minor_size, long unsigned int major_size, long u
   percent_free = norm_pfree (percent_fr);
   percent_max = norm_pmax (percent_m);
   init_major_heap (major_heap_size);
-  gc_message ("Initial minor heap size: %luk bytes\n", minor_heap_size / 1024);
-  gc_message ("Initial major heap size: %luk bytes\n", major_heap_size / 1024);
-  gc_message ("Initial space overhead: %lu%%\n", percent_free);
-  gc_message ("Initial max overhead: %lu%%\n", percent_max);
-  gc_message ("Initial heap increment: %luk bytes\n",
+  gc_message (0x20, "Initial minor heap size: %luk bytes\n",
+              minor_heap_size / 1024);
+  gc_message (0x20, "Initial major heap size: %luk bytes\n",
+              major_heap_size / 1024);
+  gc_message (0x20, "Initial space overhead: %lu%%\n", percent_free);
+  gc_message (0x20, "Initial max overhead: %lu%%\n", percent_max);
+  gc_message (0x20, "Initial heap increment: %luk bytes\n",
               major_heap_increment / 1024);
 }
diff --git a/byterun/io.c b/byterun/io.c
index 420194466..49f2e2f1a 100644
--- a/byterun/io.c
+++ b/byterun/io.c
@@ -387,7 +387,7 @@ static void finalize_channel(value vchan)
 
 static value alloc_channel(struct channel *chan)
 {
-  value res = alloc_final(2, finalize_channel, 1, 32);
+  value res = alloc_final(2, finalize_channel, 1, 1000);
   Field(res, 1) = (value) chan;
   return res;
 }
diff --git a/byterun/major_gc.c b/byterun/major_gc.c
index 987abd82c..e6f115f99 100644
--- a/byterun/major_gc.c
+++ b/byterun/major_gc.c
@@ -37,7 +37,7 @@ unsigned long percent_free;
 long major_heap_increment;
 char *heap_start, *heap_end;
 page_table_entry *page_table;
-asize_t page_table_size;
+asize_t page_low, page_high;
 char *gc_sweep_hp;
 int gc_phase;
 static value *gray_vals;
@@ -46,7 +46,7 @@ static asize_t gray_vals_size;
 static int heap_is_pure;   /* The heap is pure if the only gray objects
                               below [markhp] are also in [gray_vals]. */
 unsigned long allocated_words;
-unsigned long extra_heap_memory;
+double extra_heap_memory;
 extern char *fl_merge;  /* Defined in freelist.c. */
 
 static char *markhp, *chunk, *limit;
@@ -59,12 +59,12 @@ static void realloc_gray_vals (void)
 
   Assert (gray_vals_cur == gray_vals_end);
   if (gray_vals_size < stat_heap_size / 128){
-    gc_message ("Growing gray_vals to %luk bytes\n",
+    gc_message (0x08, "Growing gray_vals to %luk bytes\n",
                 (long) gray_vals_size * sizeof (value) / 512);
     new = (value *) realloc ((char *) gray_vals,
                              2 * gray_vals_size * sizeof (value));
     if (new == NULL){
-      gc_message ("No room for growing gray_vals\n", 0);
+      gc_message (0x08, "No room for growing gray_vals\n", 0);
       gray_vals_cur = gray_vals;
       heap_is_pure = 0;
     }else{
@@ -79,9 +79,7 @@ static void realloc_gray_vals (void)
   }
 }
 
-void darken (value v, value *p)
-             
-                /* not used */
+void darken (value v, value *p /* not used */)
 {
   if (Is_block (v) && Is_in_heap (v)) {
     if (Tag_val(v) == Infix_tag) v -= Infix_offset_val(v);
@@ -97,12 +95,13 @@ static void start_cycle (void)
 {
   Assert (gc_phase == Phase_idle);
   Assert (gray_vals_cur == gray_vals);
+  gc_message (0x01, "Starting new major GC cycle\n", 0);
   darken_all_roots();
   gc_phase = Phase_mark;
   markhp = NULL;
 }
 
-static void mark_slice (long int work)
+static void mark_slice (long work)
 {
   value *gray_vals_ptr;  /* Local copy of gray_vals_cur */
   value v, child;
@@ -255,6 +254,7 @@ static void sweep_slice (long int work)
 /* The main entry point for the GC.  Called at each minor GC. */
 void major_collection_slice (void)
 {
+  double p;
   /* 
      Free memory at the start of the GC cycle (garbage + free list) (assumed):
                  FM = stat_heap_size * percent_free / (100 + percent_free)
@@ -262,22 +262,22 @@ void major_collection_slice (void)
                  G = FM * 2/3
      Proportion of free memory consumed since the previous slice:
                  PH = allocated_words / G
+                    = 3 * allocated_words * (100 + percent_free)
+                      / (2 * stat_heap_size * percent_free)
      Proportion of extra-heap memory consumed since the previous slice:
-                 PE = extra_heap_memory / stat_heap_size
+                 PE = extra_heap_memory
      Proportion of total work to do in this slice:
-                 P  = PH + PE
+                 P  = max (PH, PE)
      Amount of marking work for the GC cycle:
                  MW = stat_heap_size * 100 / (100 + percent_free)
      Amount of sweeping work for the GC cycle:
                  SW = stat_heap_size
      Amount of marking work for this slice:
-                 MS = MW * P
-                 MS = 3/2 * 100 * allocated_words / percent_free
-                      + extra_heap_memory * 100 / (100 + percent_free)
+                 MS = P * MW
+                 MS = P * stat_heap_size * 100 / (100 + percent_free)
      Amount of sweeping work for this slice:
-                 SS = SW * P
-                 SS = 3/2 * (100 + percent_free)/percent_free * allocated_words
-                      + extra_heap_memory
+                 SS = P * SW
+                 SS = P * stat_heap_size
      This slice will either mark 2*MS words or sweep 2*SS words.
   */
 
@@ -285,24 +285,38 @@ void major_collection_slice (void)
 
   if (gc_phase == Phase_idle) start_cycle ();
 
+  p = 1.5 * allocated_words * (100 + percent_free)
+      / stat_heap_size / percent_free;
+  if (p < extra_heap_memory) p = extra_heap_memory;
+
+  gc_message (0x40, "allocated_words = %lu\n", allocated_words);
+  gc_message (0x40, "extra_heap_memory = %luu\n",
+              (unsigned long) (extra_heap_memory * 1000000));
+  gc_message (0x40, "amount of work to do = %luu\n",
+              (unsigned long) (p * 1000000));
+
   if (gc_phase == Phase_mark){
-    mark_slice (300 * (allocated_words / percent_free + 1)
-                + 200 * (extra_heap_memory / (100 + percent_free) + 1)
-		+ Margin);
-    gc_message ("!", 0);
+    long work = (long) (p * stat_heap_size * 100 / (100+percent_free)) + Margin;
+    if (verb_gc & 0x40){
+      gc_message (0x40, "Marking %lu words\n", work);
+    }
+    mark_slice (work);
+    gc_message (0x02, "!", 0);
   }else{
+    long work = (long) (p * stat_heap_size) + Margin;
     Assert (gc_phase == Phase_sweep);
-    sweep_slice (3 * (100 + percent_free) * (allocated_words / percent_free + 1)
-                 + 2 * extra_heap_memory
-                 + Margin);
-    gc_message ("$", 0);
+    if (verb_gc & 0x40){
+      gc_message (0x40, "Sweeping %lu words\n", work);
+    }
+    sweep_slice (work);
+    gc_message (0x02, "$", 0);
   }
 
   if (gc_phase == Phase_idle) compact_heap_maybe ();
 
   stat_major_words += allocated_words;
   allocated_words = 0;
-  extra_heap_memory = 0;
+  extra_heap_memory = 0.0;
 }
 
 /* The minor heap must be empty when this function is called. */
@@ -338,6 +352,8 @@ void init_major_heap (asize_t heap_size)
 {
   asize_t i;
   void *block;
+  asize_t page_table_size;
+  page_table_entry *page_table_block;
 
   stat_heap_size = round_heap_chunk_size (heap_size);
   Assert (stat_heap_size % Page_size == 0);
@@ -352,17 +368,21 @@ void init_major_heap (asize_t heap_size)
   Chunk_block (heap_start) = block;
   heap_end = heap_start + stat_heap_size;
   Assert ((unsigned long) heap_end % Page_size == 0);
-  page_table_size = 4 * stat_heap_size / Page_size;
-  page_table = 
-    (page_table_entry *) malloc (page_table_size * sizeof(page_table_entry));
-  if (page_table == NULL)
+
+  page_low = Page (heap_start);
+  page_high = Page (heap_end);
+
+  page_table_size = page_high - page_low;
+  page_table_block = 
+    (page_table_entry *) malloc (page_table_size * sizeof (page_table_entry));
+  if (page_table_block == NULL){
     fatal_error ("Fatal error: not enough memory for the initial heap.\n");
-  for (i = 0; i < page_table_size; i++){
-    page_table [i] = Not_in_heap;
   }
+  page_table = page_table_block - page_low;
   for (i = Page (heap_start); i < Page (heap_end); i++){
     page_table [i] = In_heap;
   }
+
   Hd_hp (heap_start) = Make_header (Wosize_bhsize (stat_heap_size), 0, Blue);
   fl_init_merge ();
   fl_merge_block (Bp_hp (heap_start));
@@ -375,5 +395,5 @@ void init_major_heap (asize_t heap_size)
   gray_vals_end = gray_vals + gray_vals_size;
   heap_is_pure = 1;
   allocated_words = 0;
-  extra_heap_memory = 0;
+  extra_heap_memory = 0.0;
 }
diff --git a/byterun/major_gc.h b/byterun/major_gc.h
index 47c56e267..dee4119d0 100644
--- a/byterun/major_gc.h
+++ b/byterun/major_gc.h
@@ -32,7 +32,7 @@ typedef struct {
 
 extern int gc_phase;
 extern unsigned long allocated_words;
-extern unsigned long extra_heap_memory;
+extern double extra_heap_memory;
 
 #define Phase_mark 0
 #define Phase_sweep 1
@@ -48,12 +48,12 @@ extern char *heap_start;
 extern char *heap_end;
 extern unsigned long total_heap_size;
 extern page_table_entry *page_table;
-extern asize_t page_table_size;
+extern asize_t page_low, page_high;
 extern char *gc_sweep_hp;
 
 #define In_heap 1
 #define Not_in_heap 0
-#define Page(p) (((addr) (p) - (addr) heap_start) >> Page_log)
+#define Page(p) ((unsigned long) (p) >> Page_log)
 #define Is_in_heap(p) \
   ((addr)(p) >= (addr)heap_start && (addr)(p) < (addr)heap_end \
    && page_table [Page (p)])
diff --git a/byterun/memory.c b/byterun/memory.c
index be05da132..6d6b65ade 100644
--- a/byterun/memory.c
+++ b/byterun/memory.c
@@ -24,83 +24,102 @@
 #include "mlvalues.h"
 #include "signals.h"
 
-/* Allocate more memory from malloc for the heap.
-   Return a block of at least the requested size (in words).
-   Return NULL when out of memory.
-
-   Faudrait nettoyer tout ca pour decoupler heap_start de heap_base
-   et pour simplifier l'agrandissement de page_table.
+/* Allocate a block of the requested size, which will be passed to
+   [add_to_heap] later.
+   [request] must be a multiple of [Page_size].
+   [alloc_for_heap] returns NULL if the request cannot be satisfied.
+   The returned pointer is a hp, but the header must be initialized by
+   the caller.
 */
-static char *expand_heap (mlsize_t request)
+header_t *alloc_for_heap (asize_t request)
 {
   char *mem;
-  page_table_entry *new_page_table;
-  asize_t new_page_table_size;
-  asize_t malloc_request;
-  asize_t i, more_pages;
   void *block;
-
-  malloc_request = round_heap_chunk_size (Bhsize_wosize (request));
-  gc_message ("Growing heap to %luk bytes\n",
-              (stat_heap_size + malloc_request) / 1024);
-  mem = aligned_malloc (malloc_request + sizeof (heap_chunk_head),
+                                              Assert (request % Page_size == 0);
+  mem = aligned_malloc (request + sizeof (heap_chunk_head),
                         sizeof (heap_chunk_head), &block);
-  if (mem == NULL){
-    gc_message ("No room for growing heap\n", 0);
-    return NULL;
-  }
+  if (mem == NULL) return NULL;
   mem += sizeof (heap_chunk_head);
-  Chunk_size (mem) = malloc_request;
+  Chunk_size (mem) = request;
   Chunk_block (mem) = block;
-  Assert (Wosize_bhsize (malloc_request) >= request);
-  Hd_hp (mem) = Make_header (Wosize_bhsize (malloc_request), 0, Blue);
+  return (header_t *) mem;
+}
 
-  if (mem < heap_start){
-    more_pages = -Page (mem);
-  }else if (Page (mem + malloc_request) > page_table_size){
-    more_pages = Page (mem + malloc_request) - page_table_size;
-  }else{
-    more_pages = 0;
-  }
+/* Take a block of memory as argument, which must be the result of a
+   call to [alloc_for_heap], and insert it into the heap chaining.
+   The contents of the block must be a sequence of valid objects and
+   fragments: no space between objects and no trailing garbage.  If
+   some objects are blue, they must be added to the free list by the
+   caller.  All other objects must have the color [allocation_color(mem)].
+   The caller must update [allocated_words] if applicable.
+   Return value: 0 if no error; -1 in case of error.
+*/
+int add_to_heap (header_t *arg_mem)
+{
+  asize_t i;
+  char *mem = (char *) arg_mem;
+                                     Assert (Chunk_size (mem) % Page_size == 0);
+#ifdef DEBUG
+  /* Should check the contents of the block. */
+#endif /* debug */
 
-  if (more_pages != 0){
-    new_page_table_size = page_table_size + more_pages;
-    new_page_table =
-      (page_table_entry *) 
-        malloc(new_page_table_size * sizeof(page_table_entry));
-    if (new_page_table == NULL){
-      gc_message ("No room for growing page table\n", 0);
-      free (mem);
-      return NULL;
+  /* Extend the page table as needed. */
+  if (Page (mem) < page_low){
+    page_table_entry *block, *new_page_table;
+    asize_t new_page_low = Page (mem);
+    asize_t new_size = page_high - new_page_low;
+    
+    gc_message (0x08, "Growing page table to %lu entries\n", new_size);
+    block = malloc (new_size * sizeof (page_table_entry));
+    if (block == NULL){
+      gc_message (0x08, "No room for growing page table\n", 0);
+      return -1;
     }
-  } else {
-    new_page_table = NULL;
-    new_page_table_size = 0;
+    new_page_table = block - new_page_low;
+    for (i = new_page_low; i < page_low; i++) new_page_table [i] = Not_in_heap;
+    for (i = page_low; i < page_high; i++) new_page_table [i] = page_table [i];
+    free (page_table + page_low);
+    page_table = new_page_table;
+    page_low = new_page_low;
   }
-
-  if (mem < heap_start){
-    Assert (more_pages != 0);
-    for (i = 0; i < more_pages; i++){
+  if (Page (mem + Chunk_size (mem)) > page_high){
+    page_table_entry *block, *new_page_table;
+    asize_t new_page_high = Page (mem + Chunk_size (mem));
+    asize_t new_size = new_page_high - page_low;
+    
+    gc_message (0x08, "Growing page table to %lu entries\n", new_size);
+    block = malloc (new_size * sizeof (page_table_entry));
+    if (block == NULL){
+      gc_message (0x08, "No room for growing page table\n", 0);
+      return -1;
+    }
+    new_page_table = block - page_low;
+    for (i = page_low; i < page_high; i++) new_page_table [i] = page_table [i];
+    for (i = page_high; i < new_page_high; i++){
       new_page_table [i] = Not_in_heap;
     }
-    bcopy (page_table, new_page_table + more_pages,
-           page_table_size * sizeof(page_table_entry));
+    free (page_table + page_low);
+    page_table = new_page_table;
+    page_high = new_page_high;
+  }
+
+  /* Update the heap bounds as needed. */
+  if (mem < heap_start) heap_start = mem;
+  if (mem + Chunk_size (mem) > heap_end) heap_end = mem + Chunk_size (mem);
+
+  /* Mark the pages as being in the heap. */
+  for (i = Page (mem); i < Page (mem + Chunk_size (mem)); i++){
+    page_table [i] = In_heap;
+  }
+
+  /* Chain this heap block. */
+  if (mem < heap_start){
     Chunk_next (mem) = heap_start;
     heap_start = mem;
   }else{
-    char **last;
-    char *cur;
-
-    if (mem + malloc_request > heap_end) heap_end = mem + malloc_request;
-    if (more_pages != 0){
-      for (i = page_table_size; i < new_page_table_size; i++){
-        new_page_table [i] = Not_in_heap;
-      }
-      bcopy (page_table, new_page_table, 
-             page_table_size * sizeof(page_table_entry));
-    }
-    last = &heap_start;
-    cur = *last;
+    char **last = &heap_start;
+    char *cur = *last;
+
     while (cur != NULL && cur < mem){
       last = &(Chunk_next (cur));
       cur = *last;
@@ -108,22 +127,40 @@ static char *expand_heap (mlsize_t request)
     Chunk_next (mem) = cur;
     *last = mem;
   }
+  stat_heap_size += Chunk_size (mem);
+  return 0;
+}
 
-  if (more_pages != 0){
-    free ((char *) page_table);
-    page_table = new_page_table;
-    page_table_size = new_page_table_size;
+/* 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.
+   Return NULL when out of memory.
+*/
+static char *expand_heap (mlsize_t request)
+{
+  header_t *mem;
+  asize_t malloc_request;
+
+  malloc_request = round_heap_chunk_size (Bhsize_wosize (request));
+  gc_message (0x04, "Growing heap to %luk bytes\n",
+              (stat_heap_size + malloc_request) / 1024);
+  mem = alloc_for_heap (malloc_request);
+  if (mem == NULL){
+    gc_message (0x04, "No room for growing heap\n", 0);
+    return NULL;
   }
+  Assert (Wosize_bhsize (malloc_request) >= request);
+  Hd_hp (mem) = Make_header (Wosize_bhsize (malloc_request), 0, Blue);
 
-  for (i = Page (mem); i < Page (mem + malloc_request); i++){
-    page_table [i] = In_heap;
+  if (add_to_heap (mem) != 0){
+    free (mem);
+    return NULL;
   }
-  stat_heap_size += malloc_request;
   return Bp_hp (mem);
 }
 
 /* Remove the heap chunk [chunk] from the heap and give the memory back
-   to [malloc].
+   to [free].
 */
 void shrink_heap (char *chunk)
 {
@@ -139,7 +176,7 @@ void shrink_heap (char *chunk)
   if (chunk == heap_start) return;
 
   stat_heap_size -= Chunk_size (chunk);
-  gc_message ("Shrinking heap to %luk bytes\n", stat_heap_size / 1024);
+  gc_message (0x04, "Shrinking heap to %luk bytes\n", stat_heap_size / 1024);
 
 #ifdef DEBUG
   {
@@ -164,6 +201,18 @@ void shrink_heap (char *chunk)
   free (Chunk_block (chunk));
 }
 
+color_t allocation_color (void *hp)
+{
+  if (gc_phase == Phase_mark
+      || (gc_phase == Phase_sweep && (addr)hp >= (addr)gc_sweep_hp)){
+    return Black;
+  }else{
+    Assert (gc_phase == Phase_idle
+            || (gc_phase == Phase_sweep && (addr)hp < (addr)gc_sweep_hp));
+    return White;
+  }
+}
+
 value alloc_shr (mlsize_t wosize, tag_t tag)
 {
   char *hp, *new_block;
@@ -183,6 +232,7 @@ value alloc_shr (mlsize_t wosize, tag_t tag)
 
   Assert (Is_in_heap (Val_hp (hp)));
 
+  /* Inline expansion of allocation_color. */
   if (gc_phase == Phase_mark
       || (gc_phase == Phase_sweep && (addr)hp >= (addr)gc_sweep_hp)){
     Hd_hp (hp) = Make_header (wosize, tag, Black);
@@ -191,6 +241,7 @@ value alloc_shr (mlsize_t wosize, tag_t tag)
             || (gc_phase == Phase_sweep && (addr)hp < (addr)gc_sweep_hp));
     Hd_hp (hp) = Make_header (wosize, tag, White);
   }
+  Assert (Hd_hp (hp) == Make_header (wosize, tag, allocation_color (hp)));
   allocated_words += Whsize_wosize (wosize);
   if (allocated_words > Wsize_bsize (minor_heap_size)) urge_major_slice ();
   return Val_hp (hp);
@@ -202,18 +253,21 @@ value alloc_shr (mlsize_t wosize, tag_t tag)
    [mem] is the number of words allocated this time.
    Note that only [mem/max] is relevant.  You can use numbers of bytes
    (or kilobytes, ...) instead of words.  You can change units between
-   calls to [adjust_collector_speed].
+   calls to [adjust_gc_speed].
 */
 void adjust_gc_speed (mlsize_t mem, mlsize_t max)
 {
   if (max == 0) max = 1;
   if (mem > max) mem = max;
-  extra_heap_memory += ((float) mem / max) * stat_heap_size;
-  if (extra_heap_memory > stat_heap_size){
-    extra_heap_memory = stat_heap_size;
+  extra_heap_memory += (double) mem / (double) max;
+  if (extra_heap_memory > 1.0){
+    extra_heap_memory = 1.0;
+    urge_major_slice ();
   }
-  if (extra_heap_memory > Wsize_bsize (minor_heap_size) / 2) 
+  if (extra_heap_memory > (double) Wsize_bsize (minor_heap_size)
+                          / 2.0 / (double) stat_heap_size) {
     urge_major_slice ();
+  }
 }
 
 /* You must use [initialize] to store the initial value in a field of
diff --git a/byterun/memory.h b/byterun/memory.h
index c2866a1f7..007290660 100644
--- a/byterun/memory.h
+++ b/byterun/memory.h
@@ -32,6 +32,9 @@ value check_urgent_gc (value);
 void * stat_alloc (asize_t);              /* Size in bytes. */
 void stat_free (void *);
 void * stat_resize (void *, asize_t);     /* Size in bytes. */
+header_t *alloc_for_heap (asize_t request);   /* Size in bytes. */
+int add_to_heap (header_t *mem);
+color_t allocation_color (void *hp);
 
 /* void shrink_heap (char *);        Only used in compact.c */
 
diff --git a/byterun/meta.c b/byterun/meta.c
index 2e995fffc..705658002 100644
--- a/byterun/meta.c
+++ b/byterun/meta.c
@@ -56,7 +56,7 @@ value realloc_global(value size)      /* ML */
   actual_size = Wosize_val(global_data);
   if (requested_size >= actual_size) {
     requested_size = (requested_size + 0x100) & 0xFFFFFF00;
-    gc_message ("Growing global data to %lu entries.\n", requested_size);
+    gc_message (0x08, "Growing global data to %lu entries\n", requested_size);
     new_global_data = alloc_shr(requested_size, 0);
     for (i = 0; i < actual_size; i++)
       initialize(&Field(new_global_data, i), Field(global_data, i));
diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c
index bfa0c5644..06cc45ef7 100644
--- a/byterun/minor_gc.c
+++ b/byterun/minor_gc.c
@@ -123,14 +123,14 @@ void minor_collection (void)
   long prev_alloc_words = allocated_words;
 
   in_minor_collection = 1;
-  gc_message ("<", 0);
+  gc_message (0x02, "<", 0);
   oldify_local_roots();
   for (r = ref_table; r < ref_table_ptr; r++) oldify (**r, *r);
   stat_minor_words += Wsize_bsize (young_end - young_ptr);
   young_ptr = young_end;
   ref_table_ptr = ref_table;
   ref_table_limit = ref_table_threshold;
-  gc_message (">", 0);
+  gc_message (0x02, ">", 0);
   in_minor_collection = 0;
 
   stat_promoted_words += allocated_words - prev_alloc_words;
@@ -155,7 +155,7 @@ void realloc_ref_table (void)
                             Assert (ref_table_limit >= ref_table_threshold);
 
   if (ref_table_limit == ref_table_threshold){
-    gc_message ("ref_table threshold crossed\n", 0);
+    gc_message (0x08, "ref_table threshold crossed\n", 0);
     ref_table_limit = ref_table_end;
     urge_major_slice ();
   }else{ /* This will almost never happen with the bytecode interpreter. */
@@ -165,7 +165,7 @@ void realloc_ref_table (void)
 
     ref_table_size *= 2;
     sz = (ref_table_size + ref_table_reserve) * sizeof (value *);
-    gc_message ("Growing ref_table to %ldk bytes\n", (long) sz / 1024);
+    gc_message (0x08, "Growing ref_table to %ldk bytes\n", (long) sz / 1024);
     ref_table = (value **) realloc ((char *) ref_table, sz);
     if (ref_table == NULL) fatal_error ("Fatal error: ref_table overflow\n");
     ref_table_end = ref_table + ref_table_size + ref_table_reserve;
diff --git a/byterun/misc.c b/byterun/misc.c
index e1cc71f98..167dd670b 100644
--- a/byterun/misc.c
+++ b/byterun/misc.c
@@ -39,9 +39,9 @@ unsigned long not_random (void)
 
 int verb_gc;
 
-void gc_message (char *msg, long unsigned int arg)
+void gc_message (int level, char *msg, unsigned long arg)
 {
-  if (verb_gc){
+  if (verb_gc & level){
 #ifdef HAS_UI
     ui_print_stderr(msg, (void *) arg);
 #else
@@ -151,9 +151,6 @@ void memmov (char * dst, char * src, unsigned long length)
 #endif /* USING_MEMMOV */
 
 char *aligned_malloc (asize_t size, int modulo, void **block)
-                  
-                
-                        /* output */
 {
   char *raw_mem;
   unsigned long aligned_mem;
diff --git a/byterun/misc.h b/byterun/misc.h
index 355379702..69ee009e2 100644
--- a/byterun/misc.h
+++ b/byterun/misc.h
@@ -72,7 +72,7 @@ void fatal_error_arg (char *, char *) Noreturn;
 /* GC flags and messages */
 
 extern int verb_gc;
-void gc_message (char *, unsigned long);
+void gc_message (int, char *, unsigned long);
 
 /* Memory routines */
 
diff --git a/byterun/stacks.c b/byterun/stacks.c
index cad3df901..811728c4a 100644
--- a/byterun/stacks.c
+++ b/byterun/stacks.c
@@ -39,7 +39,7 @@ void init_stack (long unsigned int initial_max_size)
   trapsp = stack_high;
   trap_barrier = stack_high + 1;
   max_stack_size = initial_max_size;
-  gc_message ("Initial stack limit: %luk bytes\n",
+  gc_message (0x08, "Initial stack limit: %luk bytes\n",
 	      max_stack_size / 1024 * sizeof (value));
 }
 
@@ -53,7 +53,7 @@ void realloc_stack(void)
   size = stack_high - stack_low;
   if (size >= max_stack_size) raise_stack_overflow();
   size *= 2;
-  gc_message ("Growing stack to %luk bytes\n",
+  gc_message (0x08, "Growing stack to %luk bytes\n",
               (unsigned long) size * sizeof(value) / 1024);
   new_low = (value *) stat_alloc(size * sizeof(value));
   new_high = new_low + size;
@@ -84,7 +84,7 @@ void change_max_stack_size (long unsigned int new_max_size)
 
   if (new_max_size < size) new_max_size = size;
   if (new_max_size != max_stack_size){
-    gc_message ("Changing stack limit to %luk bytes\n",
+    gc_message (0x08, "Changing stack limit to %luk bytes\n",
                 new_max_size * sizeof (value) / 1024);
   }
   max_stack_size = new_max_size;
diff --git a/byterun/startup.c b/byterun/startup.c
index ace071e22..ff6c0dca5 100644
--- a/byterun/startup.c
+++ b/byterun/startup.c
@@ -180,7 +180,7 @@ static int parse_command_line(char **argv)
       break;
 #endif
     case 'v':
-      verbose_init = 1;
+      verbose_init = 1+4+8+16+32;
       break;
     case 'p':
       for (j = 0; names_of_cprim[j] != NULL; j++)