diff options
Diffstat (limited to 'test/monniaux/ocaml/byterun/obj.c')
-rw-r--r-- | test/monniaux/ocaml/byterun/obj.c | 390 |
1 files changed, 390 insertions, 0 deletions
diff --git a/test/monniaux/ocaml/byterun/obj.c b/test/monniaux/ocaml/byterun/obj.c new file mode 100644 index 00000000..4567b8ae --- /dev/null +++ b/test/monniaux/ocaml/byterun/obj.c @@ -0,0 +1,390 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +#define CAML_INTERNALS + +/* Operations on objects */ + +#include <string.h> +#include "caml/alloc.h" +#include "caml/fail.h" +#include "caml/gc.h" +#include "caml/interp.h" +#include "caml/major_gc.h" +#include "caml/memory.h" +#include "caml/minor_gc.h" +#include "caml/misc.h" +#include "caml/mlvalues.h" +#include "caml/prims.h" +#include "caml/spacetime.h" + +/* [size] is a value encoding a number of bytes */ +CAMLprim value caml_static_alloc(value size) +{ + return (value) caml_stat_alloc((asize_t) Long_val(size)); +} + +CAMLprim value caml_static_free(value blk) +{ + caml_stat_free((void *) blk); + return Val_unit; +} + +CAMLprim value caml_static_resize(value blk, value new_size) +{ + return (value) caml_stat_resize((char *) blk, (asize_t) Long_val(new_size)); +} + +/* unused since GPR#427 */ +CAMLprim value caml_obj_is_block(value arg) +{ + return Val_bool(Is_block(arg)); +} + +CAMLprim value caml_obj_tag(value arg) +{ + if (Is_long (arg)){ + return Val_int (1000); /* int_tag */ + }else if ((long) arg & (sizeof (value) - 1)){ + return Val_int (1002); /* unaligned_tag */ + }else if (Is_in_value_area (arg)){ + return Val_int(Tag_val(arg)); + }else{ + return Val_int (1001); /* out_of_heap_tag */ + } +} + +CAMLprim value caml_obj_set_tag (value arg, value new_tag) +{ + Tag_val (arg) = Int_val (new_tag); + return Val_unit; +} + +/* [size] is a value encoding a number of blocks */ +CAMLprim value caml_obj_block(value tag, value size) +{ + value res; + mlsize_t sz, i; + tag_t tg; + + sz = Long_val(size); + tg = Long_val(tag); + if (sz == 0) return Atom(tg); + res = caml_alloc(sz, tg); + for (i = 0; i < sz; i++) + Field(res, i) = Val_long(0); + + return res; +} + +/* Spacetime profiling assumes that this function is only called from OCaml. */ +CAMLprim value caml_obj_dup(value arg) +{ + CAMLparam1 (arg); + CAMLlocal1 (res); + mlsize_t sz, i; + tag_t tg; + + sz = Wosize_val(arg); + if (sz == 0) CAMLreturn (arg); + tg = Tag_val(arg); + if (tg >= No_scan_tag) { + res = caml_alloc(sz, tg); + memcpy(Bp_val(res), Bp_val(arg), sz * sizeof(value)); + } else if (sz <= Max_young_wosize) { + uintnat profinfo; + Get_my_profinfo_with_cached_backtrace(profinfo, sz); + res = caml_alloc_small_with_my_or_given_profinfo(sz, tg, profinfo); + for (i = 0; i < sz; i++) Field(res, i) = Field(arg, i); + } else { + res = caml_alloc_shr(sz, tg); + for (i = 0; i < sz; i++) caml_initialize(&Field(res, i), Field(arg, i)); + } + CAMLreturn (res); +} + +/* Shorten the given block to the given size and return void. + Raise Invalid_argument if the given size is less than or equal + to 0 or greater than the current size. + + algorithm: + Change the length field of the header. Make up a black object + with the leftover part of the object: this is needed in the major + heap and harmless in the minor heap. The object cannot be white + because there may still be references to it in the ref table. By + using a black object we ensure that the ref table will be emptied + before the block is reallocated (since there must be a minor + collection within each major cycle). + + [newsize] is a value encoding a number of fields (words, except + for float arrays on 32-bit architectures). +*/ +CAMLprim value caml_obj_truncate (value v, value newsize) +{ + mlsize_t new_wosize = Long_val (newsize); + header_t hd = Hd_val (v); + tag_t tag = Tag_hd (hd); + color_t color = Color_hd (hd); + mlsize_t wosize = Wosize_hd (hd); + mlsize_t i; + + if (tag == Double_array_tag) new_wosize *= Double_wosize; /* PR#156 */ + + if (new_wosize <= 0 || new_wosize > wosize){ + caml_invalid_argument ("Obj.truncate"); + } + if (new_wosize == wosize) return Val_unit; + /* PR#61: since we're about to lose our references to the elements + beyond new_wosize in v, erase them explicitly so that the GC + can darken them as appropriate. */ + if (tag < No_scan_tag) { + for (i = new_wosize; i < wosize; i++){ + caml_modify(&Field(v, i), Val_unit); +#ifdef DEBUG + Field (v, i) = Debug_free_truncate; +#endif + } + } + /* We must use an odd tag for the header of the leftovers so it does not + look like a pointer because there may be some references to it in + ref_table. */ + Field (v, new_wosize) = + Make_header (Wosize_whsize (wosize-new_wosize), Abstract_tag, Caml_black); + Hd_val (v) = + Make_header_with_profinfo (new_wosize, tag, color, Profinfo_val(v)); + return Val_unit; +} + +CAMLprim value caml_obj_add_offset (value v, value offset) +{ + return v + (unsigned long) Int32_val (offset); +} + +/* The following functions are used in stdlib/lazy.ml. + They are not written in OCaml because they must be atomic with respect + to the GC. + */ + +CAMLprim value caml_lazy_follow_forward (value v) +{ + if (Is_block (v) && Is_in_value_area(v) + && Tag_val (v) == Forward_tag){ + return Forward_val (v); + }else{ + return v; + } +} + +CAMLprim value caml_lazy_make_forward (value v) +{ + CAMLparam1 (v); + CAMLlocal1 (res); + + res = caml_alloc_small (1, Forward_tag); + Field (res, 0) = v; + CAMLreturn (res); +} + +/* For mlvalues.h and camlinternalOO.ml + See also GETPUBMET in interp.c + */ + +CAMLprim value caml_get_public_method (value obj, value tag) +{ + value meths = Field (obj, 0); + int li = 3, hi = Field(meths,0), mi; + while (li < hi) { + mi = ((li+hi) >> 1) | 1; + if (tag < Field(meths,mi)) hi = mi-2; + else li = mi; + } + /* return 0 if tag is not there */ + return (tag == Field(meths,li) ? Field (meths, li-1) : 0); +} + +/* these two functions might be useful to an hypothetical JIT */ + +#ifdef CAML_JIT +#ifdef NATIVE_CODE +#define MARK 1 +#else +#define MARK 0 +#endif +value caml_cache_public_method (value meths, value tag, value *cache) +{ + int li = 3, hi = Field(meths,0), mi; + while (li < hi) { + mi = ((li+hi) >> 1) | 1; + if (tag < Field(meths,mi)) hi = mi-2; + else li = mi; + } + *cache = (li-3)*sizeof(value) + MARK; + return Field (meths, li-1); +} + +value caml_cache_public_method2 (value *meths, value tag, value *cache) +{ + value ofs = *cache & meths[1]; + if (*(value*)(((char*)(meths+3)) + ofs - MARK) == tag) + return *(value*)(((char*)(meths+2)) + ofs - MARK); + { + int li = 3, hi = meths[0], mi; + while (li < hi) { + mi = ((li+hi) >> 1) | 1; + if (tag < meths[mi]) hi = mi-2; + else li = mi; + } + *cache = (li-3)*sizeof(value) + MARK; + return meths[li-1]; + } +} +#endif /*CAML_JIT*/ + +static value oo_last_id = Val_int(0); + +CAMLprim value caml_set_oo_id (value obj) { + Field(obj, 1) = oo_last_id; + oo_last_id += 2; + return obj; +} + +CAMLprim value caml_fresh_oo_id (value v) { + v = oo_last_id; + oo_last_id += 2; + return v; +} + +CAMLprim value caml_int_as_pointer (value n) { + return n - 1; +} + +/* Compute how many words in the heap are occupied by blocks accessible + from a given value */ + +#define ENTRIES_PER_QUEUE_CHUNK 4096 +struct queue_chunk { + struct queue_chunk *next; + value entries[ENTRIES_PER_QUEUE_CHUNK]; +}; + + +CAMLprim value caml_obj_reachable_words(value v) +{ + static struct queue_chunk first_chunk; + struct queue_chunk *read_chunk, *write_chunk; + int write_pos, read_pos, i; + + intnat size = 0; + header_t hd; + mlsize_t sz; + + if (Is_long(v) || !Is_in_heap_or_young(v)) return Val_int(0); + if (Tag_hd(Hd_val(v)) == Infix_tag) v -= Infix_offset_hd(Hd_val(v)); + hd = Hd_val(v); + sz = Wosize_hd(hd); + + read_chunk = write_chunk = &first_chunk; + read_pos = 0; + write_pos = 1; + write_chunk->entries[0] = v | Colornum_hd(hd); + Hd_val(v) = Bluehd_hd(hd); + + /* We maintain a queue of "interesting" blocks that have been seen. + An interesting block is a block in the heap which does not + represent an infix pointer. Infix pointers are normalized to the + beginning of their block. Blocks in the static data area are excluded. + + The function maintains a queue of block pointers. Concretely, + the queue is stored as a linked list of chunks, each chunk + holding a number of pointers to interesting blocks. Initially, + it contains only the "root" value. The first chunk of the queue + is allocated statically. More chunks can be allocated as needed + and released before this function exits. + + When a block is inserted in the queue, it is marked as blue. + This mark is used to avoid a second visit of the same block. + The real color is stored in the last 2 bits of the pointer in the + queue. (Same technique as in extern.c.) + + Note: we make the assumption that there is no pointer + from the static data area to the heap. + */ + + /* First pass: mark accessible blocks and compute their total size */ + while (read_pos != write_pos || read_chunk != write_chunk) { + /* Pop the next element from the queue */ + if (read_pos == ENTRIES_PER_QUEUE_CHUNK) { + read_pos = 0; + read_chunk = read_chunk->next; + } + v = read_chunk->entries[read_pos++] & ~3; + + hd = Hd_val(v); + sz = Wosize_hd(hd); + + size += Whsize_wosize(sz); + + if (Tag_hd(hd) < No_scan_tag) { + /* Push the interesting fields on the queue */ + for (i = 0; i < sz; i++) { + value v2 = Field(v, i); + if (Is_block(v2) && Is_in_heap_or_young(v2)) { + if (Tag_hd(Hd_val(v2)) == Infix_tag){ + v2 -= Infix_offset_hd(Hd_val(v2)); + } + hd = Hd_val(v2); + if (Color_hd(hd) != Caml_blue) { + if (write_pos == ENTRIES_PER_QUEUE_CHUNK) { + struct queue_chunk *new_chunk = + malloc(sizeof(struct queue_chunk)); + if (new_chunk == NULL) { + size = (-1); + goto release; + } + write_chunk->next = new_chunk; + write_pos = 0; + write_chunk = new_chunk; + } + write_chunk->entries[write_pos++] = v2 | Colornum_hd(hd); + Hd_val(v2) = Bluehd_hd(hd); + } + } + } + } + } + + /* Second pass: restore colors and free extra queue chunks */ + release: + read_pos = 0; + read_chunk = &first_chunk; + while (read_pos != write_pos || read_chunk != write_chunk) { + color_t colornum; + if (read_pos == ENTRIES_PER_QUEUE_CHUNK) { + struct queue_chunk *prev = read_chunk; + read_pos = 0; + read_chunk = read_chunk->next; + if (prev != &first_chunk) free(prev); + } + v = read_chunk->entries[read_pos++]; + colornum = v & 3; + v &= ~3; + Hd_val(v) = Coloredhd_hd(Hd_val(v), colornum); + } + if (read_chunk != &first_chunk) free(read_chunk); + + if (size < 0) + caml_raise_out_of_memory(); + return Val_int(size); +} |