l4/pkg/ocaml/contrib/byterun/minor_gc.c

   1 /***********************************************************************/
   2 /*                                                                     */
   3 /*                           Objective Caml                            */
   4 /*                                                                     */
   5 /*             Damien Doligez, projet Para, INRIA Rocquencourt         */
   6 /*                                                                     */
   7 /*  Copyright 1996 Institut National de Recherche en Informatique et   */
   8 /*  en Automatique.  All rights reserved.  This file is distributed    */
   9 /*  under the terms of the GNU Library General Public License, with    */
  10 /*  the special exception on linking described in file ../LICENSE.     */
  11 /*                                                                     */
  12 /***********************************************************************/
  13
  14 /* $Id: minor_gc.c 8954 2008-07-28 12:03:55Z doligez $ */
  15
  16 #include <string.h>
  17 #include "config.h"
  18 #include "fail.h"
  19 #include "finalise.h"
  20 #include "gc.h"
  21 #include "gc_ctrl.h"
  22 #include "major_gc.h"
  23 #include "memory.h"
  24 #include "minor_gc.h"
  25 #include "misc.h"
  26 #include "mlvalues.h"
  27 #include "roots.h"
  28 #include "signals.h"
  29 #include "weak.h"
  30
  31 asize_t caml_minor_heap_size;
  32 static void *caml_young_base = NULL;
  33 CAMLexport char *caml_young_start = NULL, *caml_young_end = NULL;
  34 CAMLexport char *caml_young_ptr = NULL, *caml_young_limit = NULL;
  35
  36 CAMLexport struct caml_ref_table
  37   caml_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0},
  38   caml_weak_ref_table = { NULL, NULL, NULL, NULL, NULL, 0, 0};
  39
  40 int caml_in_minor_collection = 0;
  41
  42 #ifdef DEBUG
  43 static unsigned long minor_gc_counter = 0;
  44 #endif
  45
  46 void caml_alloc_table (struct caml_ref_table *tbl, asize_t sz, asize_t rsv)
  47 {
  48   value **new_table;
  49
  50   tbl->size = sz;
  51   tbl->reserve = rsv;
  52   new_table = (value **) caml_stat_alloc ((tbl->size + tbl->reserve)
  53                                           * sizeof (value *));
  54   if (tbl->base != NULL) caml_stat_free (tbl->base);
  55   tbl->base = new_table;
  56   tbl->ptr = tbl->base;
  57   tbl->threshold = tbl->base + tbl->size;
  58   tbl->limit = tbl->threshold;
  59   tbl->end = tbl->base + tbl->size + tbl->reserve;
  60 }
  61
  62 static void reset_table (struct caml_ref_table *tbl)
  63 {
  64   tbl->size = 0;
  65   tbl->reserve = 0;
  66   if (tbl->base != NULL) caml_stat_free (tbl->base);
  67   tbl->base = tbl->ptr = tbl->threshold = tbl->limit = tbl->end = NULL;
  68 }
  69
  70 static void clear_table (struct caml_ref_table *tbl)
  71 {
  72     tbl->ptr = tbl->base;
  73     tbl->limit = tbl->threshold;
  74 }
  75
  76 void caml_set_minor_heap_size (asize_t size)
  77 {
  78   char *new_heap;
  79   void *new_heap_base;
  80
  81   Assert (size >= Minor_heap_min);
  82   Assert (size <= Minor_heap_max);
  83   Assert (size % sizeof (value) == 0);
  84   if (caml_young_ptr != caml_young_end) caml_minor_collection ();
  85                                     Assert (caml_young_ptr == caml_young_end);
  86   new_heap = caml_aligned_malloc(size, 0, &new_heap_base);
  87   if (new_heap == NULL) caml_raise_out_of_memory();
  88   if (caml_page_table_add(In_young, new_heap, new_heap + size) != 0)
  89     caml_raise_out_of_memory();
  90
  91   if (caml_young_start != NULL){
  92     caml_page_table_remove(In_young, caml_young_start, caml_young_end);
  93     free (caml_young_base);
  94   }
  95   caml_young_base = new_heap_base;
  96   caml_young_start = new_heap;
  97   caml_young_end = new_heap + size;
  98   caml_young_limit = caml_young_start;
  99   caml_young_ptr = caml_young_end;
 100   caml_minor_heap_size = size;
 101
 102   reset_table (&caml_ref_table);
 103   reset_table (&caml_weak_ref_table);
 104 }
 105
 106 static value oldify_todo_list = 0;
 107
 108 /* Note that the tests on the tag depend on the fact that Infix_tag,
 109    Forward_tag, and No_scan_tag are contiguous. */
 110
 111 void caml_oldify_one (value v, value *p)
 112 {
 113   value result;
 114   header_t hd;
 115   mlsize_t sz, i;
 116   tag_t tag;
 117
 118  tail_call:
 119   if (Is_block (v) && Is_young (v)){
 120     Assert (Hp_val (v) >= caml_young_ptr);
 121     hd = Hd_val (v);
 122     if (hd == 0){         /* If already forwarded */
 123       *p = Field (v, 0);  /*  then forward pointer is first field. */
 124     }else{
 125       tag = Tag_hd (hd);
 126       if (tag < Infix_tag){
 127         value field0;
 128
 129         sz = Wosize_hd (hd);
 130         result = caml_alloc_shr (sz, tag);
 131         *p = result;
 132         field0 = Field (v, 0);
 133         Hd_val (v) = 0;            /* Set forward flag */
 134         Field (v, 0) = result;     /*  and forward pointer. */
 135         if (sz > 1){
 136           Field (result, 0) = field0;
 137           Field (result, 1) = oldify_todo_list;    /* Add this block */
 138           oldify_todo_list = v;                    /*  to the "to do" list. */
 139         }else{
 140           Assert (sz == 1);
 141           p = &Field (result, 0);
 142           v = field0;
 143           goto tail_call;
 144         }
 145       }else if (tag >= No_scan_tag){
 146         sz = Wosize_hd (hd);
 147         result = caml_alloc_shr (sz, tag);
 148         for (i = 0; i < sz; i++) Field (result, i) = Field (v, i);
 149         Hd_val (v) = 0;            /* Set forward flag */
 150         Field (v, 0) = result;     /*  and forward pointer. */
 151         *p = result;
 152       }else if (tag == Infix_tag){
 153         mlsize_t offset = Infix_offset_hd (hd);
 154         caml_oldify_one (v - offset, p);   /* Cannot recurse deeper than 1. */
 155         *p += offset;
 156       }else{
 157         value f = Forward_val (v);
 158         tag_t ft = 0;
 159         int vv = 1;
 160
 161         Assert (tag == Forward_tag);
 162         if (Is_block (f)){
 163           vv = Is_in_value_area(f);
 164           if (vv) {
 165             ft = Tag_val (Hd_val (f) == 0 ? Field (f, 0) : f);
 166           }
 167         }
 168         if (!vv || ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){
 169           /* Do not short-circuit the pointer.  Copy as a normal block. */
 170           Assert (Wosize_hd (hd) == 1);
 171           result = caml_alloc_shr (1, Forward_tag);
 172           *p = result;
 173           Hd_val (v) = 0;             /* Set (GC) forward flag */
 174           Field (v, 0) = result;      /*  and forward pointer. */
 175           p = &Field (result, 0);
 176           v = f;
 177           goto tail_call;
 178         }else{
 179           v = f;                        /* Follow the forwarding */
 180           goto tail_call;               /*  then oldify. */
 181         }
 182       }
 183     }
 184   }else{
 185     *p = v;
 186   }
 187 }
 188
 189 /* Finish the work that was put off by [caml_oldify_one].
 190    Note that [caml_oldify_one] itself is called by oldify_mopup, so we
 191    have to be careful to remove the first entry from the list before
 192    oldifying its fields. */
 193 void caml_oldify_mopup (void)
 194 {
 195   value v, new_v, f;
 196   mlsize_t i;
 197
 198   while (oldify_todo_list != 0){
 199     v = oldify_todo_list;                /* Get the head. */
 200     Assert (Hd_val (v) == 0);            /* It must be forwarded. */
 201     new_v = Field (v, 0);                /* Follow forward pointer. */
 202     oldify_todo_list = Field (new_v, 1); /* Remove from list. */
 203
 204     f = Field (new_v, 0);
 205     if (Is_block (f) && Is_young (f)){
 206       caml_oldify_one (f, &Field (new_v, 0));
 207     }
 208     for (i = 1; i < Wosize_val (new_v); i++){
 209       f = Field (v, i);
 210       if (Is_block (f) && Is_young (f)){
 211         caml_oldify_one (f, &Field (new_v, i));
 212       }else{
 213         Field (new_v, i) = f;
 214       }
 215     }
 216   }
 217 }
 218
 219 /* Make sure the minor heap is empty by performing a minor collection
 220    if needed.
 221 */
 222 void caml_empty_minor_heap (void)
 223 {
 224   value **r;
 225
 226   if (caml_young_ptr != caml_young_end){
 227     caml_in_minor_collection = 1;
 228     caml_gc_message (0x02, "<", 0);
 229     caml_oldify_local_roots();
 230     for (r = caml_ref_table.base; r < caml_ref_table.ptr; r++){
 231       caml_oldify_one (**r, *r);
 232     }
 233     caml_oldify_mopup ();
 234     for (r = caml_weak_ref_table.base; r < caml_weak_ref_table.ptr; r++){
 235       if (Is_block (**r) && Is_young (**r)){
 236         if (Hd_val (**r) == 0){
 237           **r = Field (**r, 0);
 238         }else{
 239           **r = caml_weak_none;
 240         }
 241       }
 242     }
 243     if (caml_young_ptr < caml_young_start) caml_young_ptr = caml_young_start;
 244     caml_stat_minor_words += Wsize_bsize (caml_young_end - caml_young_ptr);
 245     caml_young_ptr = caml_young_end;
 246     caml_young_limit = caml_young_start;
 247     clear_table (&caml_ref_table);
 248     clear_table (&caml_weak_ref_table);
 249     caml_gc_message (0x02, ">", 0);
 250     caml_in_minor_collection = 0;
 251   }
 252   caml_final_empty_young ();
 253 #ifdef DEBUG
 254   {
 255     value *p;
 256     for (p = (value *) caml_young_start; p < (value *) caml_young_end; ++p){
 257       *p = Debug_free_minor;
 258     }
 259     ++ minor_gc_counter;
 260   }
 261 #endif
 262 }
 263
 264 /* Do a minor collection and a slice of major collection, call finalisation
 265    functions, etc.
 266    Leave the minor heap empty.
 267 */
 268 CAMLexport void caml_minor_collection (void)
 269 {
 270   intnat prev_alloc_words = caml_allocated_words;
 271
 272   caml_empty_minor_heap ();
 273
 274   caml_stat_promoted_words += caml_allocated_words - prev_alloc_words;
 275   ++ caml_stat_minor_collections;
 276   caml_major_collection_slice (0);
 277   caml_force_major_slice = 0;
 278
 279   caml_final_do_calls ();
 280
 281   caml_empty_minor_heap ();
 282 }
 283
 284 CAMLexport value caml_check_urgent_gc (value extra_root)
 285 {
 286   CAMLparam1 (extra_root);
 287   if (caml_force_major_slice) caml_minor_collection();
 288   CAMLreturn (extra_root);
 289 }
 290
 291 void caml_realloc_ref_table (struct caml_ref_table *tbl)
 292 {                                           Assert (tbl->ptr == tbl->limit);
 293                                             Assert (tbl->limit <= tbl->end);
 294                                       Assert (tbl->limit >= tbl->threshold);
 295
 296   if (tbl->base == NULL){
 297     caml_alloc_table (tbl, caml_minor_heap_size / sizeof (value) / 8, 256);
 298   }else if (tbl->limit == tbl->threshold){
 299     caml_gc_message (0x08, "ref_table threshold crossed\n", 0);
 300     tbl->limit = tbl->end;
 301     caml_urge_major_slice ();
 302   }else{ /* This will almost never happen with the bytecode interpreter. */
 303     asize_t sz;
 304     asize_t cur_ptr = tbl->ptr - tbl->base;
 305                                              Assert (caml_force_major_slice);
 306
 307     tbl->size *= 2;
 308     sz = (tbl->size + tbl->reserve) * sizeof (value *);
 309     caml_gc_message (0x08, "Growing ref_table to %"
 310                            ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n",
 311                      (intnat) sz/1024);
 312     tbl->base = (value **) realloc ((char *) tbl->base, sz);
 313     if (tbl->base == NULL){
 314       caml_fatal_error ("Fatal error: ref_table overflow\n");
 315     }
 316     tbl->end = tbl->base + tbl->size + tbl->reserve;
 317     tbl->threshold = tbl->base + tbl->size;
 318     tbl->ptr = tbl->base + cur_ptr;
 319     tbl->limit = tbl->end;
 320   }
 321 }