1 /**************************************************************************/
2 /* */
3 /* OCaml */
4 /* */
5 /* Damien Doligez, projet Para, INRIA Rocquencourt */
6 /* */
7 /* Copyright 1997 Institut National de Recherche en Informatique et */
8 /* en Automatique. */
9 /* */
10 /* All rights reserved. This file is distributed under the terms of */
11 /* the GNU Lesser General Public License version 2.1, with the */
12 /* special exception on linking described in the file LICENSE. */
13 /* */
14 /**************************************************************************/
15
16 #define CAML_INTERNALS
17
18 /* Operations on weak arrays and ephemerons (named ephe here)*/
19
20 #include <string.h>
21
22 #include "caml/alloc.h"
23 #include "caml/fail.h"
24 #include "caml/major_gc.h"
25 #include "caml/memory.h"
26 #include "caml/mlvalues.h"
27 #include "caml/weak.h"
28
29 value caml_ephe_list_head = 0;
30
31 static value ephe_dummy = 0;
32 value caml_ephe_none = (value) &ephe_dummy;
33
34 #if defined (NATIVE_CODE) && defined (NO_NAKED_POINTERS)
35 /** The minor heap is considered alive.
36 Outside minor and major heap, x must be black.
37 */
Is_Dead_during_clean(value x)38 static inline int Is_Dead_during_clean(value x){
39 Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_clean);
40 return Is_block (x) && !Is_young (x) && Is_white_val(x);
41 }
42 /** The minor heap doesn't have to be marked, outside they should
43 already be black
44 */
Must_be_Marked_during_mark(value x)45 static inline int Must_be_Marked_during_mark(value x){
46 Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_mark);
47 return Is_block (x) && !Is_young (x);
48 }
49 #else
Is_Dead_during_clean(value x)50 static inline int Is_Dead_during_clean(value x){
51 Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_clean);
52 return Is_block (x) && Is_in_heap (x) && Is_white_val(x);
53 }
Must_be_Marked_during_mark(value x)54 static inline int Must_be_Marked_during_mark(value x){
55 Assert (x != caml_ephe_none); Assert (caml_gc_phase == Phase_mark);
56 return Is_block (x) && Is_in_heap (x);
57 }
58 #endif
59
60
61 /* [len] is a value that represents a number of words (fields) */
caml_ephe_create(value len)62 CAMLprim value caml_ephe_create (value len)
63 {
64 mlsize_t size, i;
65 value res;
66
67 size = Long_val (len) + 1 /* weak_list */ + 1 /* the value */;
68 if (size <= 0 || size > Max_wosize) caml_invalid_argument ("Weak.create");
69 res = caml_alloc_shr (size, Abstract_tag);
70 for (i = 1; i < size; i++) Field (res, i) = caml_ephe_none;
71 Field (res, CAML_EPHE_LINK_OFFSET) = caml_ephe_list_head;
72 caml_ephe_list_head = res;
73 return res;
74 }
75
caml_weak_create(value len)76 CAMLprim value caml_weak_create (value len)
77 {
78 return caml_ephe_create(len);
79 }
80
81 /**
82 Specificity of the cleaning phase (Phase_clean):
83
84 The dead keys must be removed from the ephemerons and data removed
85 when one the keys is dead. Here we call it cleaning the ephemerons.
86 A specific phase of the GC is dedicated to this, Phase_clean. This
87 phase is just after the mark phase, so the white values are dead
88 values. It iterates the function caml_ephe_clean through all the
89 ephemerons.
90
91 However the GC is incremental and ocaml code can run on the middle
92 of this cleaning phase. In order to respect the semantic of the
93 ephemerons concerning dead values, the getter and setter must work
94 as if the cleaning of all the ephemerons have been done at once.
95
96 - key getter: Even if a dead key have not yet been replaced by
97 caml_ephe_none, getting it should return none.
98 - key setter: If we replace a dead key we need to set the data to
99 caml_ephe_none and clean the ephemeron.
100
101 This two cases are dealt by a call to do_check_key_clean that
102 trigger the cleaning of the ephemerons when the accessed key is
103 dead. This test is fast.
104
105 In the case of value getter and value setter, there is no fast
106 test because the removing of the data depend of the deadliness of the keys.
107 We must always try to clean the ephemerons.
108
109 */
110
111 #define None_val (Val_int(0))
112 #define Some_tag 0
113
114 /* If we are in Phase_clean we need to check if the key
115 that is going to disappear is dead and so should trigger a cleaning
116 */
do_check_key_clean(value ar,mlsize_t offset)117 static void do_check_key_clean(value ar, mlsize_t offset){
118 Assert ( offset >= 2);
119 if (caml_gc_phase == Phase_clean){
120 value elt = Field (ar, offset);
121 if (elt != caml_ephe_none && Is_Dead_during_clean(elt)){
122 Field(ar,offset) = caml_ephe_none;
123 Field(ar,CAML_EPHE_DATA_OFFSET) = caml_ephe_none;
124 };
125 };
126 }
127
128 /* If we are in Phase_clean we need to do as if the key is empty when
129 it will be cleaned during this phase */
is_ephe_key_none(value ar,mlsize_t offset)130 static inline int is_ephe_key_none(value ar, mlsize_t offset){
131 value elt = Field (ar, offset);
132 if (elt == caml_ephe_none){
133 return 1;
134 }else if (caml_gc_phase == Phase_clean && Is_Dead_during_clean(elt)){
135 Field(ar,offset) = caml_ephe_none;
136 Field(ar,CAML_EPHE_DATA_OFFSET) = caml_ephe_none;
137 return 1;
138 } else {
139 return 0;
140 }
141 }
142
143
do_set(value ar,mlsize_t offset,value v)144 static void do_set (value ar, mlsize_t offset, value v)
145 {
146 if (Is_block (v) && Is_young (v)){
147 /* modified version of Modify */
148 value old = Field (ar, offset);
149 Field (ar, offset) = v;
150 if (!(Is_block (old) && Is_young (old))){
151 add_to_ephe_ref_table (&caml_ephe_ref_table, ar, offset);
152 }
153 }else{
154 Field (ar, offset) = v;
155 }
156 }
157
caml_ephe_set_key(value ar,value n,value el)158 CAMLprim value caml_ephe_set_key (value ar, value n, value el)
159 {
160 mlsize_t offset = Long_val (n) + 2;
161 Assert (Is_in_heap (ar));
162 if (offset < 2 || offset >= Wosize_val (ar)){
163 caml_invalid_argument ("Weak.set");
164 }
165 do_check_key_clean(ar,offset);
166 do_set (ar, offset, el);
167 return Val_unit;
168 }
169
caml_ephe_unset_key(value ar,value n)170 CAMLprim value caml_ephe_unset_key (value ar, value n)
171 {
172 mlsize_t offset = Long_val (n) + 2;
173 Assert (Is_in_heap (ar));
174 if (offset < 2 || offset >= Wosize_val (ar)){
175 caml_invalid_argument ("Weak.set");
176 }
177 do_check_key_clean(ar,offset);
178 Field (ar, offset) = caml_ephe_none;
179 return Val_unit;
180 }
181
caml_ephe_set_key_option(value ar,value n,value el)182 value caml_ephe_set_key_option (value ar, value n, value el)
183 {
184 mlsize_t offset = Long_val (n) + 2;
185 Assert (Is_in_heap (ar));
186 if (offset < 2 || offset >= Wosize_val (ar)){
187 caml_invalid_argument ("Weak.set");
188 }
189 do_check_key_clean(ar,offset);
190 if (el != None_val && Is_block (el)){
191 Assert (Wosize_val (el) == 1);
192 do_set (ar, offset, Field (el, 0));
193 }else{
194 Field (ar, offset) = caml_ephe_none;
195 }
196 return Val_unit;
197 }
198
caml_weak_set(value ar,value n,value el)199 CAMLprim value caml_weak_set (value ar, value n, value el){
200 return caml_ephe_set_key_option(ar,n,el);
201 }
202
caml_ephe_set_data(value ar,value el)203 CAMLprim value caml_ephe_set_data (value ar, value el)
204 {
205 Assert (Is_in_heap (ar));
206 if (caml_gc_phase == Phase_clean){
207 /* During this phase since we don't know which ephemeron have been
208 cleaned we always need to check it. */
209 caml_ephe_clean(ar);
210 };
211 do_set (ar, 1, el);
212 return Val_unit;
213 }
214
caml_ephe_unset_data(value ar)215 CAMLprim value caml_ephe_unset_data (value ar)
216 {
217 Assert (Is_in_heap (ar));
218 Field (ar, CAML_EPHE_DATA_OFFSET) = caml_ephe_none;
219 return Val_unit;
220 }
221
222
223 #define Setup_for_gc
224 #define Restore_after_gc
225
caml_ephe_get_key(value ar,value n)226 CAMLprim value caml_ephe_get_key (value ar, value n)
227 {
228 CAMLparam2 (ar, n);
229 mlsize_t offset = Long_val (n) + 2;
230 CAMLlocal2 (res, elt);
231 Assert (Is_in_heap (ar));
232 if (offset < 2 || offset >= Wosize_val (ar)){
233 caml_invalid_argument ("Weak.get_key");
234 }
235 if (is_ephe_key_none(ar, offset)){
236 res = None_val;
237 }else{
238 elt = Field (ar, offset);
239 if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(elt)){
240 caml_darken (elt, NULL);
241 }
242 res = caml_alloc_small (1, Some_tag);
243 Field (res, 0) = elt;
244 }
245 CAMLreturn (res);
246 }
247
caml_weak_get(value ar,value n)248 CAMLprim value caml_weak_get (value ar, value n){
249 return caml_ephe_get_key(ar, n);
250 }
251
caml_ephe_get_data(value ar)252 CAMLprim value caml_ephe_get_data (value ar)
253 {
254 CAMLparam1 (ar);
255 mlsize_t offset = 1;
256 CAMLlocal2 (res, elt);
257 Assert (Is_in_heap (ar));
258 elt = Field (ar, offset);
259 if(caml_gc_phase == Phase_clean) caml_ephe_clean(ar);
260 if (elt == caml_ephe_none){
261 res = None_val;
262 }else{
263 if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(elt)){
264 caml_darken (elt, NULL);
265 }
266 res = caml_alloc_small (1, Some_tag);
267 Field (res, 0) = elt;
268 }
269 CAMLreturn (res);
270 }
271
272 #undef Setup_for_gc
273 #undef Restore_after_gc
274
caml_ephe_get_key_copy(value ar,value n)275 CAMLprim value caml_ephe_get_key_copy (value ar, value n)
276 {
277 CAMLparam2 (ar, n);
278 mlsize_t offset = Long_val (n) + 2;
279 CAMLlocal2 (res, elt);
280 value v; /* Caution: this is NOT a local root. */
281 Assert (Is_in_heap (ar));
282 if (offset < 1 || offset >= Wosize_val (ar)){
283 caml_invalid_argument ("Weak.get_copy");
284 }
285
286 if (is_ephe_key_none(ar, offset)) CAMLreturn (None_val);
287 v = Field (ar, offset);
288 /** Don't copy custom_block #7279 */
289 if (Is_block (v) && Is_in_heap_or_young(v) && Tag_val(v) != Custom_tag ) {
290 elt = caml_alloc (Wosize_val (v), Tag_val (v));
291 /* The GC may erase or move v during this call to caml_alloc. */
292 v = Field (ar, offset);
293 if (is_ephe_key_none(ar, offset)) CAMLreturn (None_val);
294 if (Tag_val (v) < No_scan_tag){
295 mlsize_t i;
296 for (i = 0; i < Wosize_val (v); i++){
297 value f = Field (v, i);
298 if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(f)){
299 caml_darken (f, NULL);
300 }
301 Modify (&Field (elt, i), f);
302 }
303 }else{
304 memmove (Bp_val (elt), Bp_val (v), Bosize_val (v));
305 }
306 }else{
307 if ( caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(v) ){
308 caml_darken (v, NULL);
309 };
310 elt = v;
311 }
312 res = caml_alloc_small (1, Some_tag);
313 Field (res, 0) = elt;
314
315 CAMLreturn (res);
316 }
317
caml_weak_get_copy(value ar,value n)318 CAMLprim value caml_weak_get_copy (value ar, value n){
319 return caml_ephe_get_key_copy(ar,n);
320 }
321
caml_ephe_get_data_copy(value ar)322 CAMLprim value caml_ephe_get_data_copy (value ar)
323 {
324 CAMLparam1 (ar);
325 mlsize_t offset = 1;
326 CAMLlocal2 (res, elt);
327 value v; /* Caution: this is NOT a local root. */
328 Assert (Is_in_heap (ar));
329
330 v = Field (ar, offset);
331 if (caml_gc_phase == Phase_clean) caml_ephe_clean(ar);
332 if (v == caml_ephe_none) CAMLreturn (None_val);
333 /** Don't copy custom_block #7279 */
334 if (Is_block (v) && Is_in_heap_or_young(v) && Tag_val(v) != Custom_tag ) {
335 elt = caml_alloc (Wosize_val (v), Tag_val (v));
336 /* The GC may erase or move v during this call to caml_alloc. */
337 v = Field (ar, offset);
338 if (caml_gc_phase == Phase_clean) caml_ephe_clean(ar);
339 if (v == caml_ephe_none) CAMLreturn (None_val);
340 if (Tag_val (v) < No_scan_tag){
341 mlsize_t i;
342 for (i = 0; i < Wosize_val (v); i++){
343 value f = Field (v, i);
344 if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(f)){
345 caml_darken (f, NULL);
346 }
347 Modify (&Field (elt, i), f);
348 }
349 }else{
350 memmove (Bp_val (elt), Bp_val (v), Bosize_val (v));
351 }
352 }else{
353 if ( caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(v) ){
354 caml_darken (v, NULL);
355 };
356 elt = v;
357 }
358 res = caml_alloc_small (1, Some_tag);
359 Field (res, 0) = elt;
360
361 CAMLreturn (res);
362 }
363
caml_ephe_check_key(value ar,value n)364 CAMLprim value caml_ephe_check_key (value ar, value n)
365 {
366 mlsize_t offset = Long_val (n) + 2;
367 Assert (Is_in_heap (ar));
368 if (offset < 2 || offset >= Wosize_val (ar)){
369 caml_invalid_argument ("Weak.check");
370 }
371 return Val_bool (!is_ephe_key_none(ar, offset));
372 }
373
caml_weak_check(value ar,value n)374 CAMLprim value caml_weak_check (value ar, value n)
375 {
376 return caml_ephe_check_key(ar,n);
377 }
378
caml_ephe_check_data(value ar)379 CAMLprim value caml_ephe_check_data (value ar)
380 {
381 if(caml_gc_phase == Phase_clean) caml_ephe_clean(ar);
382 return Val_bool (Field (ar, CAML_EPHE_DATA_OFFSET) != caml_ephe_none);
383 }
384
caml_ephe_blit_key(value ars,value ofs,value ard,value ofd,value len)385 CAMLprim value caml_ephe_blit_key (value ars, value ofs,
386 value ard, value ofd, value len)
387 {
388 mlsize_t offset_s = Long_val (ofs) + 2;
389 mlsize_t offset_d = Long_val (ofd) + 2;
390 mlsize_t length = Long_val (len);
391 long i;
392 Assert (Is_in_heap (ars));
393 Assert (Is_in_heap (ard));
394 if (offset_s < 1 || offset_s + length > Wosize_val (ars)){
395 caml_invalid_argument ("Weak.blit");
396 }
397 if (offset_d < 1 || offset_d + length > Wosize_val (ard)){
398 caml_invalid_argument ("Weak.blit");
399 }
400 if (caml_gc_phase == Phase_clean){
401 caml_ephe_clean(ars);
402 caml_ephe_clean(ard);
403 }
404 if (offset_d < offset_s){
405 for (i = 0; i < length; i++){
406 do_set (ard, offset_d + i, Field (ars, offset_s + i));
407 }
408 }else{
409 for (i = length - 1; i >= 0; i--){
410 do_set (ard, offset_d + i, Field (ars, offset_s + i));
411 }
412 }
413 return Val_unit;
414 }
415
caml_ephe_blit_data(value ars,value ard)416 CAMLprim value caml_ephe_blit_data (value ars, value ard)
417 {
418 if(caml_gc_phase == Phase_clean) {
419 caml_ephe_clean(ars);
420 caml_ephe_clean(ard);
421 };
422 do_set (ard, CAML_EPHE_DATA_OFFSET, Field (ars, CAML_EPHE_DATA_OFFSET));
423 return Val_unit;
424 }
425
caml_weak_blit(value ars,value ofs,value ard,value ofd,value len)426 CAMLprim value caml_weak_blit (value ars, value ofs,
427 value ard, value ofd, value len)
428 {
429 return caml_ephe_blit_key (ars, ofs, ard, ofd, len);
430 }
431