byterun/finalise.c

   1 /***********************************************************************/
   2 /*                                                                     */
   3 /*                           Objective Caml                            */
   4 /*                                                                     */
   5 /*          Damien Doligez, projet Moscova, INRIA Rocquencourt         */
   6 /*                                                                     */
   7 /*  Copyright 2000 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$ */
  15
  16 /* Handling of finalised values. */
  17
  18 #include "callback.h"
  19 #include "fail.h"
  20 #include "mlvalues.h"
  21 #include "roots.h"
  22 #include "signals.h"
  23
  24 struct final {
  25   value fun;
  26   value val;
  27   int offset;
  28 };
  29
  30 static struct final *final_table = NULL;
  31 static uintnat old = 0, young = 0, size = 0;
  32 /* [0..old) : finalisable set
  33    [old..young) : recent set
  34    [young..size) : free space
  35 */
  36
  37 struct to_do {
  38   struct to_do *next;
  39   int size;
  40   struct final item[1];  /* variable size */
  41 };
  42
  43 static struct to_do *to_do_hd = NULL;
  44 static struct to_do *to_do_tl = NULL;
  45
  46 static void alloc_to_do (int size)
  47 {
  48   struct to_do *result = malloc (sizeof (struct to_do)
  49                                  + size * sizeof (struct final));
  50   if (result == NULL) caml_fatal_error ("out of memory");
  51   result->next = NULL;
  52   result->size = size;
  53   if (to_do_tl == NULL){
  54     to_do_hd = result;
  55     to_do_tl = result;
  56   }else{
  57     Assert (to_do_tl->next == NULL);
  58     to_do_tl->next = result;
  59     to_do_tl = result;
  60   }
  61 }
  62
  63 /* Find white finalisable values, put them in the finalising set, and
  64    darken them.
  65    The recent set is empty.
  66 */
  67 void caml_final_update (void)
  68 {
  69   uintnat i, j, k;
  70   uintnat todo_count = 0;
  71
  72   Assert (young == old);
  73   for (i = 0; i < old; i++){
  74     Assert (Is_block (final_table[i].val));
  75     Assert (Is_in_heap (final_table[i].val));
  76     if (Is_white_val (final_table[i].val)) ++ todo_count;
  77   }
  78
  79   if (todo_count > 0){
  80     alloc_to_do (todo_count);
  81     j = k = 0;
  82     for (i = 0; i < old; i++){
  83     again:
  84       Assert (Is_block (final_table[i].val));
  85       Assert (Is_in_heap (final_table[i].val));
  86       if (Is_white_val (final_table[i].val)){
  87         if (Tag_val (final_table[i].val) == Forward_tag){
  88           value fv;
  89           Assert (final_table[i].offset == 0);
  90           fv = Forward_val (final_table[i].val);
  91           if (Is_block (fv) && (Is_young (fv) || Is_in_heap (fv))
  92               && (Tag_val (fv) == Forward_tag || Tag_val (fv) == Lazy_tag
  93                   || Tag_val (fv) == Double_tag)){
  94             /* Do not short-circuit the pointer. */
  95           }else{
  96             final_table[i].val = fv;
  97             if (Is_block (final_table[i].val)
  98                 && Is_in_heap (final_table[i].val)){
  99               goto again;
 100             }
 101           }
 102         }
 103         to_do_tl->item[k++] = final_table[i];
 104       }else{
 105         final_table[j++] = final_table[i];
 106       }
 107     }
 108     young = old = j;
 109     to_do_tl->size = k;
 110     for (i = 0; i < k; i++){
 111       CAMLassert (Is_white_val (to_do_tl->item[i].val));
 112       caml_darken (to_do_tl->item[i].val, NULL);
 113     }
 114   }
 115 }
 116
 117 static int running_finalisation_function = 0;
 118
 119 /* Call the finalisation functions for the finalising set.
 120    Note that this function must be reentrant.
 121 */
 122 void caml_final_do_calls (void)
 123 {
 124   struct final f;
 125
 126   if (running_finalisation_function) return;
 127
 128   if (to_do_hd != NULL){
 129     caml_gc_message (0x80, "Calling finalisation functions.\n", 0);
 130     while (1){
 131       while (to_do_hd != NULL && to_do_hd->size == 0){
 132         struct to_do *next_hd = to_do_hd->next;
 133         free (to_do_hd);
 134         to_do_hd = next_hd;
 135         if (to_do_hd == NULL) to_do_tl = NULL;
 136       }
 137       if (to_do_hd == NULL) break;
 138       Assert (to_do_hd->size > 0);
 139       -- to_do_hd->size;
 140       f = to_do_hd->item[to_do_hd->size];
 141       running_finalisation_function = 1;
 142       caml_callback (f.fun, f.val + f.offset);
 143       running_finalisation_function = 0;
 144     }
 145     caml_gc_message (0x80, "Done calling finalisation functions.\n", 0);
 146   }
 147 }
 148
 149 /* Call a scanning_action [f] on [x]. */
 150 #define Call_action(f,x) (*(f)) ((x), &(x))
 151
 152 /* Call [*f] on the closures of the finalisable set and
 153    the closures and values of the finalising set.
 154    The recent set is empty.
 155    This is called by the major GC and the compactor
 156    through [caml_darken_all_roots].
 157 */
 158 void caml_final_do_strong_roots (scanning_action f)
 159 {
 160   uintnat i;
 161   struct to_do *todo;
 162
 163   Assert (old == young);
 164   for (i = 0; i < old; i++) Call_action (f, final_table[i].fun);
 165
 166   for (todo = to_do_hd; todo != NULL; todo = todo->next){
 167     for (i = 0; i < todo->size; i++){
 168       Call_action (f, todo->item[i].fun);
 169       Call_action (f, todo->item[i].val);
 170     }
 171   }
 172 }
 173
 174 /* Call [*f] on the values of the finalisable set.
 175    The recent set is empty.
 176    This is called directly by the compactor.
 177 */
 178 void caml_final_do_weak_roots (scanning_action f)
 179 {
 180   uintnat i;
 181
 182   Assert (old == young);
 183   for (i = 0; i < old; i++) Call_action (f, final_table[i].val);
 184 }
 185
 186 /* Call [*f] on the closures and values of the recent set.
 187    This is called by the minor GC through [caml_oldify_local_roots].
 188 */
 189 void caml_final_do_young_roots (scanning_action f)
 190 {
 191   uintnat i;
 192
 193   Assert (old <= young);
 194   for (i = old; i < young; i++){
 195     Call_action (f, final_table[i].fun);
 196     Call_action (f, final_table[i].val);
 197   }
 198 }
 199
 200 /* Empty the recent set into the finalisable set.
 201    This is called at the end of each minor collection.
 202    The minor heap must be empty when this is called.
 203 */
 204 void caml_final_empty_young (void)
 205 {
 206   old = young;
 207 }
 208
 209 /* Put (f,v) in the recent set. */
 210 CAMLprim value caml_final_register (value f, value v)
 211 {
 212   if (!(Is_block (v) && (Is_in_heap (v) || Is_young (v)))){
 213     caml_invalid_argument ("Gc.finalise");
 214   }
 215   Assert (old <= young);
 216
 217   if (young >= size){
 218     if (final_table == NULL){
 219       uintnat new_size = 30;
 220       final_table = caml_stat_alloc (new_size * sizeof (struct final));
 221       Assert (old == 0);
 222       Assert (young == 0);
 223       size = new_size;
 224     }else{
 225       uintnat new_size = size * 2;
 226       final_table = caml_stat_resize (final_table,
 227                                       new_size * sizeof (struct final));
 228       size = new_size;
 229     }
 230   }
 231   Assert (young < size);
 232   final_table[young].fun = f;
 233   if (Tag_val (v) == Infix_tag){
 234     final_table[young].offset = Infix_offset_val (v);
 235     final_table[young].val = v - Infix_offset_val (v);
 236   }else{
 237     final_table[young].offset = 0;
 238     final_table[young].val = v;
 239   }
 240   ++ young;
 241
 242   return Val_unit;
 243 }
 244
 245 CAMLprim value caml_final_release (value unit)
 246 {
 247   running_finalisation_function = 0;
 248   return Val_unit;
 249 }