diff --git a/Changes b/Changes index 5381616c9a45..604b5d4d5d83 100644 --- a/Changes +++ b/Changes @@ -12,6 +12,9 @@ Working version ### Runtime system: +- #9293: Use addrmap hash table for marshaling + (Stephen Dolan and KC Sivaramakrishnan) + - #9119: Make [caml_stat_resize_noexc] compatible with the [realloc] API when the old block is NULL. (Jacques-Henri Jourdan, review by Xavier Leroy) diff --git a/runtime/.depend b/runtime/.depend index 20abc79d9040..cc4fa5a61d5d 100644 --- a/runtime/.depend +++ b/runtime/.depend @@ -151,12 +151,15 @@ io_b.$(O): io.c caml/config.h caml/m.h caml/s.h caml/alloc.h caml/misc.h \ caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ caml/domain.h caml/misc.h caml/mlvalues.h caml/osdeps.h caml/memory.h \ caml/signals.h caml/sys.h +addrmap_b.$(O): addrmap.c caml/config.h caml/m.h caml/s.h caml/memory.h \ + caml/compatibility.h caml/config.h caml/misc.h caml/mlvalues.h \ + caml/domain_state.h caml/domain_state.tbl caml/domain.h caml/addrmap.h extern_b.$(O): extern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \ caml/config.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \ caml/io.h caml/io.h caml/md5.h caml/memory.h caml/gc.h caml/major_gc.h \ caml/freelist.h caml/minor_gc.h caml/address_class.h caml/domain.h \ - caml/misc.h caml/mlvalues.h caml/reverse.h + caml/misc.h caml/mlvalues.h caml/reverse.h caml/addrmap.h intern_b.$(O): intern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \ caml/callback.h caml/config.h caml/custom.h caml/fail.h caml/gc.h \ @@ -448,12 +451,15 @@ io_bd.$(O): io.c caml/config.h caml/m.h caml/s.h caml/alloc.h caml/misc.h \ caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ caml/domain.h caml/misc.h caml/mlvalues.h caml/osdeps.h caml/memory.h \ caml/signals.h caml/sys.h +addrmap_bd.$(O): addrmap.c caml/config.h caml/m.h caml/s.h caml/memory.h \ + caml/compatibility.h caml/config.h caml/misc.h caml/mlvalues.h \ + caml/domain_state.h caml/domain_state.tbl caml/domain.h caml/addrmap.h extern_bd.$(O): extern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \ caml/config.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \ caml/io.h caml/io.h caml/md5.h caml/memory.h caml/gc.h caml/major_gc.h \ caml/freelist.h caml/minor_gc.h caml/address_class.h caml/domain.h \ - caml/misc.h caml/mlvalues.h caml/reverse.h + caml/misc.h caml/mlvalues.h caml/reverse.h caml/addrmap.h intern_bd.$(O): intern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \ caml/callback.h caml/config.h caml/custom.h caml/fail.h caml/gc.h \ @@ -750,12 +756,15 @@ io_bi.$(O): io.c caml/config.h caml/m.h caml/s.h caml/alloc.h caml/misc.h \ caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ caml/domain.h caml/misc.h caml/mlvalues.h caml/osdeps.h caml/memory.h \ caml/signals.h caml/sys.h +addrmap_bi.$(O): addrmap.c caml/config.h caml/m.h caml/s.h caml/memory.h \ + caml/compatibility.h caml/config.h caml/misc.h caml/mlvalues.h \ + caml/domain_state.h caml/domain_state.tbl caml/domain.h caml/addrmap.h extern_bi.$(O): extern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \ caml/config.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \ caml/io.h caml/io.h caml/md5.h caml/memory.h caml/gc.h caml/major_gc.h \ caml/freelist.h caml/minor_gc.h caml/address_class.h caml/domain.h \ - caml/misc.h caml/mlvalues.h caml/reverse.h + caml/misc.h caml/mlvalues.h caml/reverse.h caml/addrmap.h intern_bi.$(O): intern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \ caml/callback.h caml/config.h caml/custom.h caml/fail.h caml/gc.h \ @@ -1047,12 +1056,15 @@ io_bpic.$(O): io.c caml/config.h caml/m.h caml/s.h caml/alloc.h caml/misc.h \ caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ caml/domain.h caml/misc.h caml/mlvalues.h caml/osdeps.h caml/memory.h \ caml/signals.h caml/sys.h +addrmap_bpic.$(O): addrmap.c caml/config.h caml/m.h caml/s.h caml/memory.h \ + caml/compatibility.h caml/config.h caml/misc.h caml/mlvalues.h \ + caml/domain_state.h caml/domain_state.tbl caml/domain.h caml/addrmap.h extern_bpic.$(O): extern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \ caml/config.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \ caml/io.h caml/io.h caml/md5.h caml/memory.h caml/gc.h caml/major_gc.h \ caml/freelist.h caml/minor_gc.h caml/address_class.h caml/domain.h \ - caml/misc.h caml/mlvalues.h caml/reverse.h + caml/misc.h caml/mlvalues.h caml/reverse.h caml/addrmap.h intern_bpic.$(O): intern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \ caml/callback.h caml/config.h caml/custom.h caml/fail.h caml/gc.h \ @@ -1303,12 +1315,15 @@ io_n.$(O): io.c caml/config.h caml/m.h caml/s.h caml/alloc.h caml/misc.h \ caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ caml/domain.h caml/misc.h caml/mlvalues.h caml/osdeps.h caml/memory.h \ caml/signals.h caml/sys.h +addrmap_n.$(O): addrmap.c caml/config.h caml/m.h caml/s.h caml/memory.h \ + caml/compatibility.h caml/config.h caml/misc.h caml/mlvalues.h \ + caml/domain_state.h caml/domain_state.tbl caml/domain.h caml/addrmap.h extern_n.$(O): extern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \ caml/config.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \ caml/io.h caml/io.h caml/md5.h caml/memory.h caml/gc.h caml/major_gc.h \ caml/freelist.h caml/minor_gc.h caml/address_class.h caml/domain.h \ - caml/misc.h caml/mlvalues.h caml/reverse.h + caml/misc.h caml/mlvalues.h caml/reverse.h caml/addrmap.h intern_n.$(O): intern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \ caml/callback.h caml/config.h caml/custom.h caml/fail.h caml/gc.h \ @@ -1596,12 +1611,15 @@ io_nd.$(O): io.c caml/config.h caml/m.h caml/s.h caml/alloc.h caml/misc.h \ caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ caml/domain.h caml/misc.h caml/mlvalues.h caml/osdeps.h caml/memory.h \ caml/signals.h caml/sys.h +addrmap_nd.$(O): addrmap.c caml/config.h caml/m.h caml/s.h caml/memory.h \ + caml/compatibility.h caml/config.h caml/misc.h caml/mlvalues.h \ + caml/domain_state.h caml/domain_state.tbl caml/domain.h caml/addrmap.h extern_nd.$(O): extern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \ caml/config.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \ caml/io.h caml/io.h caml/md5.h caml/memory.h caml/gc.h caml/major_gc.h \ caml/freelist.h caml/minor_gc.h caml/address_class.h caml/domain.h \ - caml/misc.h caml/mlvalues.h caml/reverse.h + caml/misc.h caml/mlvalues.h caml/reverse.h caml/addrmap.h intern_nd.$(O): intern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \ caml/callback.h caml/config.h caml/custom.h caml/fail.h caml/gc.h \ @@ -1889,12 +1907,15 @@ io_ni.$(O): io.c caml/config.h caml/m.h caml/s.h caml/alloc.h caml/misc.h \ caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ caml/domain.h caml/misc.h caml/mlvalues.h caml/osdeps.h caml/memory.h \ caml/signals.h caml/sys.h +addrmap_ni.$(O): addrmap.c caml/config.h caml/m.h caml/s.h caml/memory.h \ + caml/compatibility.h caml/config.h caml/misc.h caml/mlvalues.h \ + caml/domain_state.h caml/domain_state.tbl caml/domain.h caml/addrmap.h extern_ni.$(O): extern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \ caml/config.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \ caml/io.h caml/io.h caml/md5.h caml/memory.h caml/gc.h caml/major_gc.h \ caml/freelist.h caml/minor_gc.h caml/address_class.h caml/domain.h \ - caml/misc.h caml/mlvalues.h caml/reverse.h + caml/misc.h caml/mlvalues.h caml/reverse.h caml/addrmap.h intern_ni.$(O): intern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \ caml/callback.h caml/config.h caml/custom.h caml/fail.h caml/gc.h \ @@ -2182,12 +2203,15 @@ io_npic.$(O): io.c caml/config.h caml/m.h caml/s.h caml/alloc.h caml/misc.h \ caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \ caml/domain.h caml/misc.h caml/mlvalues.h caml/osdeps.h caml/memory.h \ caml/signals.h caml/sys.h +addrmap_npic.$(O): addrmap.c caml/config.h caml/m.h caml/s.h caml/memory.h \ + caml/compatibility.h caml/config.h caml/misc.h caml/mlvalues.h \ + caml/domain_state.h caml/domain_state.tbl caml/domain.h caml/addrmap.h extern_npic.$(O): extern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \ caml/config.h caml/custom.h caml/fail.h caml/gc.h caml/intext.h \ caml/io.h caml/io.h caml/md5.h caml/memory.h caml/gc.h caml/major_gc.h \ caml/freelist.h caml/minor_gc.h caml/address_class.h caml/domain.h \ - caml/misc.h caml/mlvalues.h caml/reverse.h + caml/misc.h caml/mlvalues.h caml/reverse.h caml/addrmap.h intern_npic.$(O): intern.c caml/alloc.h caml/misc.h caml/config.h caml/m.h \ caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \ caml/callback.h caml/config.h caml/custom.h caml/fail.h caml/gc.h \ diff --git a/runtime/Makefile b/runtime/Makefile index 8b798d899b33..3dfdcc4f02f6 100644 --- a/runtime/Makefile +++ b/runtime/Makefile @@ -24,14 +24,14 @@ BYTECODE_C_SOURCES := $(addsuffix .c, \ interp misc stacks fix_code startup_aux startup_byt freelist major_gc \ minor_gc memory alloc roots_byt globroots fail_byt signals \ signals_byt printexc backtrace_byt backtrace compare ints \ - floats str array io extern intern hash sys meta parsing gc_ctrl md5 obj \ - lexing callback debugger weak compact finalise custom dynlink \ + floats str array io addrmap extern intern hash sys meta parsing gc_ctrl \ + md5 obj lexing callback debugger weak compact finalise custom dynlink \ spacetime_byt afl $(UNIX_OR_WIN32) bigarray main memprof domain) NATIVE_C_SOURCES := $(addsuffix .c, \ startup_aux startup_nat main fail_nat roots_nat signals \ signals_nat misc freelist major_gc minor_gc memory alloc compare ints \ - floats str array io extern intern hash sys parsing gc_ctrl md5 obj \ + floats str array io addrmap extern intern hash sys parsing gc_ctrl md5 obj \ lexing $(UNIX_OR_WIN32) printexc callback weak compact finalise custom \ globroots backtrace_nat backtrace dynlink_nat debugger meta \ dynlink clambda_checks spacetime_nat spacetime_snapshot afl bigarray \ diff --git a/runtime/addrmap.c b/runtime/addrmap.c new file mode 100644 index 000000000000..f8f55966e986 --- /dev/null +++ b/runtime/addrmap.c @@ -0,0 +1,168 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* KC Sivaramakrishnan, Indian Institute of Technology, Madras */ +/* Stephen Dolan, University of Cambridge */ +/* */ +/* Copyright 2020 Indian Institute of Technology, Madras */ +/* Copyright 2020 University of Cambridge */ +/* */ +/* 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 + +#include "caml/config.h" +#include "caml/memory.h" +#include "caml/addrmap.h" +#include "caml/startup_aux.h" + +int addrmap_page_table_initialize(struct addrmap_page_table *t, mlsize_t count) +{ + uintnat pagesize = Page(count * 4); + + t->size = 1; + t->shift = 8 * sizeof(uintnat); + + /* Aim for initial load factor between 1/4 and 1/2 */ + while (t->size < 2 * pagesize) { + t->size <<= 1; + t->shift -= 1; + } + t->mask = t->size - 1; + t->occupancy = 0; + + /* Allocate for entries */ + mlsize_t sz = t->size; + CAMLassert(sz > 0 && (sz & (sz - 1)) == 0); /* sz must be a power of 2 */ + t->entries = caml_stat_alloc(sizeof(struct addrmap_entry) * sz); + for (int i = 0; i < sz; i++) { + t->entries[i].key = ADDRMAP_INVALID_KEY; + t->entries[i].value = ADDRMAP_NOT_PRESENT; + } + + if (t->entries == NULL) + return -1; + else + return 0; +} + +void display_addrmap(struct addrmap_page_table* t) +{ + mlsize_t i; + + printf("Display addrmap page table entries\n"); + printf("size = %ld\n", t->size); + printf("occupancy = %ld\n", t->occupancy); + for (i = 0; i < t->size; i++) + printf("addrmap_page_table.entries[%ld] = %ld:%ld\n", i, t->entries[i].key, t->entries[i].value); + printf("\n\n"); +} + +int addrmap_page_table_resize(struct addrmap_page_table* t) +{ + struct addrmap_entry* new_entries; + uintnat i, h, new_size, new_shift, new_mask; + + caml_gc_message (0x08, "Growing page table to %" + ARCH_INTNAT_PRINTF_FORMAT "u entries\n", + t->size); + + new_size = t->size * 2; + new_shift = t->shift - 1; + new_mask = new_size - 1; + new_entries = caml_stat_alloc(sizeof(struct addrmap_entry) * new_size); + + for (int i = 0; i < new_size; i++) { + new_entries[i].key = ADDRMAP_INVALID_KEY; + new_entries[i].value = ADDRMAP_NOT_PRESENT; + } + + for (i = 0; i < t->size; i++) { + struct addrmap_entry e = t->entries[i]; + if (e.key != ADDRMAP_INVALID_KEY) { + h = Hash(Page(e.key), new_shift); + + if (new_entries[h].key == ADDRMAP_INVALID_KEY) { + new_entries[h].key = t->entries[i].key; + new_entries[h].value = t->entries[i].value; + } + else { + while (1) { + h = (h + 1) & new_mask; + if (new_entries[h].key == ADDRMAP_INVALID_KEY) { + new_entries[h].key = t->entries[i].key; + new_entries[h].value = t->entries[i].value; + break; + } + } + } + } + } + + t->size = new_size; + t->shift = new_shift; + t->mask = new_mask; + + caml_stat_free(t->entries); + t->entries = new_entries; + return 0; +} + +value* addrmap_page_table_lookup(struct addrmap_page_table* t, value key) +{ + uintnat h; /* e, i; */ + + h = Hash(Page(key), t->shift); + /* The first hit is almost always successful, so optimize for this case */ + if (t->entries[h].key == ADDRMAP_INVALID_KEY) { + t->entries[h].key = key; + t->occupancy++; + } + if (t->entries[h].key == key) { + return &t->entries[h].value; + } + + while (1) { + h = (h + 1) & t->mask; + if (t->entries[h].key == ADDRMAP_INVALID_KEY) { + t->entries[h].key = key; + t->occupancy++; + } + if (t->entries[h].key == key) { + return &t->entries[h].value; + } + } + + return NULL; +} + +void caml_addrmap_clear(struct addrmap_page_table* t) { + caml_stat_free(t->entries); + t->entries = NULL; + t->occupancy = 0; + t->mask = 0; + t->shift = 0; + t->size = 0; +} + +void caml_addrmap_initialize(struct addrmap_page_table* t) { + addrmap_page_table_initialize(t, caml_init_intern_addrmap_size); +} + +value* caml_addrmap_insert_pos(struct addrmap_page_table* t, value key) { + CAMLassert(Is_block(key)); + + /* Resize to keep load factor around 0.9 */ + if (t->occupancy > 0.9 * t->size) { + + if (addrmap_page_table_resize(t) != 0) { + return NULL; + } + } + return addrmap_page_table_lookup(t, key); +} diff --git a/runtime/caml/addrmap.h b/runtime/caml/addrmap.h new file mode 100644 index 000000000000..006dea70746a --- /dev/null +++ b/runtime/caml/addrmap.h @@ -0,0 +1,62 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Stephen Dolan, University of Cambridge */ +/* */ +/* Copyright 2020 Indian Institute of Technology, Madras */ +/* Copyright 2020 University of Cambridge */ +/* */ +/* 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. */ +/* */ +/**************************************************************************/ + +#ifndef CAML_ADDRMAP_H +#define CAML_ADDRMAP_H + +#ifdef CAML_INTERNALS + +#include "mlvalues.h" + +#define Page(p) ((uintnat) (p) >> 2) + +/* Multiplicative Fibonacci hashing + (Knuth, TAOCP vol 3, section 6.4, page 518). + HASH_FACTOR is (sqrt(5) - 1) / 2 * 2^wordsize. */ +#ifdef ARCH_SIXTYFOUR +#define HASH_FACTOR 11400714819323198486UL +#else +#define HASH_FACTOR 2654435769UL +#endif +#define Hash(key,shift) (((key) * HASH_FACTOR) >> shift) + +struct addrmap_entry { value key, value; }; + +struct addrmap_page_table { + mlsize_t size; /* size == 1 << (wordsize - shift) */ + int shift; + mlsize_t mask; /* mask == size - 1 */ + mlsize_t occupancy; + struct addrmap_entry* entries; /* [size] */ +}; + +value* caml_addrmap_lookup(struct addrmap_page_table* t, value key); + +#define ADDRMAP_NOT_PRESENT ((value)(0)) +#define ADDRMAP_INVALID_KEY ((value)(0)) + +value* caml_addrmap_insert_pos(struct addrmap_page_table* t, value v); + +void caml_addrmap_clear(struct addrmap_page_table* t); + +void caml_addrmap_initialize(struct addrmap_page_table* t); + +void display_addrmap(struct addrmap_page_table* t); +value* addrmap_page_table_lookup(struct addrmap_page_table* t, value key); +int addrmap_page_table_resize(struct addrmap_page_table* t); + +#endif /* CAML_INTERNALS */ + +#endif /* CAML_ADDRMAP_H */ diff --git a/runtime/caml/config.h b/runtime/caml/config.h index d1f93bb9c874..2308012f78f5 100644 --- a/runtime/caml/config.h +++ b/runtime/caml/config.h @@ -254,4 +254,7 @@ typedef uint64_t uintnat; Documented in gc.mli */ #define Custom_minor_max_bsz_def 8192 +/* Default initial number of entries in the addrmap hash table */ +#define Init_intern_addrmap_def 256 + #endif /* CAML_CONFIG_H */ diff --git a/runtime/caml/misc.h b/runtime/caml/misc.h index 7fea2b14435c..8070070bda6f 100644 --- a/runtime/caml/misc.h +++ b/runtime/caml/misc.h @@ -199,6 +199,10 @@ CAMLextern void caml_fatal_error (char *, ...) #endif CAMLnoreturn_end; +#ifdef CAML_INTERNALS +#define Is_power_of_2(x) (((x) & ((x) - 1)) == 0) +#endif /* CAML_INTERNALS */ + /* Detection of available C built-in functions, the Clang way. */ #ifdef __has_builtin diff --git a/runtime/caml/startup_aux.h b/runtime/caml/startup_aux.h index 77ced69fa0aa..5da030a4d67f 100644 --- a/runtime/caml/startup_aux.h +++ b/runtime/caml/startup_aux.h @@ -36,6 +36,7 @@ extern uintnat caml_init_custom_major_ratio; extern uintnat caml_init_custom_minor_ratio; extern uintnat caml_init_custom_minor_max_bsz; extern uintnat caml_trace_level; +extern uintnat caml_init_intern_addrmap_size; extern int caml_cleanup_on_exit; extern void caml_parse_ocamlrunparam (void); diff --git a/runtime/extern.c b/runtime/extern.c index 5409d7b18c0f..991a041fcf6f 100644 --- a/runtime/extern.c +++ b/runtime/extern.c @@ -32,6 +32,7 @@ #include "caml/misc.h" #include "caml/mlvalues.h" #include "caml/reverse.h" +#include "caml/addrmap.h" static uintnat obj_counter; /* Number of objects emitted so far */ static uintnat size_32; /* Size in words of 32-bit block for struct. */ @@ -48,22 +49,7 @@ enum { static int extern_flags; /* logical or of some of the flags above */ -/* Trail mechanism to undo forwarding pointers put inside objects */ - -struct trail_entry { - value obj; /* address of object + initial color in low 2 bits */ - value field0; /* initial contents of field 0 */ -}; - -struct trail_block { - struct trail_block * previous; - struct trail_entry entries[ENTRIES_PER_TRAIL_BLOCK]; -}; - -static struct trail_block extern_trail_first; -static struct trail_block * extern_trail_block; -static struct trail_entry * extern_trail_cur, * extern_trail_limit; - +static struct addrmap_page_table recorded_objs; /* Stack for pending values to marshal */ @@ -96,7 +82,6 @@ CAMLnoreturn_start static void extern_stack_overflow(void) CAMLnoreturn_end; -static void extern_replay_trail(void); static void free_extern_output(void); /* Free the extern stack if needed */ @@ -132,68 +117,10 @@ static struct extern_item * extern_resize_stack(struct extern_item * sp) return newstack + sp_offset; } -/* Initialize the trail */ - -static void init_extern_trail(void) -{ - extern_trail_block = &extern_trail_first; - extern_trail_cur = extern_trail_block->entries; - extern_trail_limit = extern_trail_block->entries + ENTRIES_PER_TRAIL_BLOCK; -} - -/* Replay the trail, undoing the in-place modifications - performed on objects */ - -static void extern_replay_trail(void) -{ - struct trail_block * blk, * prevblk; - struct trail_entry * ent, * lim; - - blk = extern_trail_block; - lim = extern_trail_cur; - while (1) { - for (ent = &(blk->entries[0]); ent < lim; ent++) { - value obj = ent->obj; - color_t colornum = obj & 3; - obj = obj & ~3; - Hd_val(obj) = Coloredhd_hd(Hd_val(obj), colornum); - Field(obj, 0) = ent->field0; - } - if (blk == &extern_trail_first) break; - prevblk = blk->previous; - caml_stat_free(blk); - blk = prevblk; - lim = &(blk->entries[ENTRIES_PER_TRAIL_BLOCK]); - } - /* Protect against a second call to extern_replay_trail */ - extern_trail_block = &extern_trail_first; - extern_trail_cur = extern_trail_block->entries; -} - -/* Set forwarding pointer on an object and add corresponding entry - to the trail. */ - -static void extern_record_location(value obj) -{ - header_t hdr; - +static void extern_record_location(value* loc) { if (extern_flags & NO_SHARING) return; - if (extern_trail_cur == extern_trail_limit) { - struct trail_block * new_block = - caml_stat_alloc_noexc(sizeof(struct trail_block)); - if (new_block == NULL) extern_out_of_memory(); - new_block->previous = extern_trail_block; - extern_trail_block = new_block; - extern_trail_cur = extern_trail_block->entries; - extern_trail_limit = extern_trail_block->entries + ENTRIES_PER_TRAIL_BLOCK; - } - hdr = Hd_val(obj); - extern_trail_cur->obj = obj | Colornum_hd(hdr); - extern_trail_cur->field0 = Field(obj, 0); - extern_trail_cur++; - Hd_val(obj) = Bluehd_hd(hdr); - Field(obj, 0) = (value) obj_counter; - obj_counter++; + CAMLassert(loc); + *loc = Val_long(obj_counter++); } /* To buffer the output */ @@ -280,21 +207,21 @@ static intnat extern_output_length(void) static void extern_out_of_memory(void) { - extern_replay_trail(); + caml_addrmap_clear(&recorded_objs); free_extern_output(); caml_raise_out_of_memory(); } static void extern_invalid_argument(char *msg) { - extern_replay_trail(); + caml_addrmap_clear(&recorded_objs); free_extern_output(); caml_invalid_argument(msg); } static void extern_failwith(char *msg) { - extern_replay_trail(); + caml_addrmap_clear(&recorded_objs); free_extern_output(); caml_failwith(msg); } @@ -302,7 +229,7 @@ static void extern_failwith(char *msg) static void extern_stack_overflow(void) { caml_gc_message (0x04, "Stack overflow in marshaling value\n"); - extern_replay_trail(); + caml_addrmap_clear(&recorded_objs); free_extern_output(); caml_raise_out_of_memory(); } @@ -417,6 +344,7 @@ static void extern_rec(value v) header_t hd = Hd_val(v); tag_t tag = Tag_hd(hd); mlsize_t sz = Wosize_hd(hd); + value* output_location; if (tag == Forward_tag) { value f = Forward_val (v); @@ -447,9 +375,9 @@ static void extern_rec(value v) } goto next_item; } - /* Check if already seen */ - if (Color_hd(hd) == Caml_blue) { - uintnat d = obj_counter - (uintnat) Field(v, 0); + output_location = caml_addrmap_insert_pos(&recorded_objs, v); + if (output_location && *output_location != ADDRMAP_NOT_PRESENT) { + uintnat d = obj_counter - (uintnat)Long_val(*output_location); if (d < 0x100) { writecode8(CODE_SHARED8, d); } else if (d < 0x10000) { @@ -488,7 +416,7 @@ static void extern_rec(value v) writeblock(String_val(v), len); size_32 += 1 + (len + 4) / 4; size_64 += 1 + (len + 8) / 8; - extern_record_location(v); + extern_record_location(output_location); break; } case Double_tag: { @@ -498,7 +426,7 @@ static void extern_rec(value v) writeblock_float8((double *) v, 1); size_32 += 1 + 2; size_64 += 1 + 1; - extern_record_location(v); + extern_record_location(output_location); break; } case Double_array_tag: { @@ -524,7 +452,7 @@ static void extern_rec(value v) writeblock_float8((double *) v, nfloats); size_32 += 1 + nfloats * 2; size_64 += 1 + nfloats; - extern_record_location(v); + extern_record_location(output_location); break; } case Abstract_tag: @@ -568,7 +496,7 @@ static void extern_rec(value v) } size_32 += 2 + ((sz_32 + 3) >> 2); /* header + ops + data */ size_64 += 2 + ((sz_64 + 7) >> 3); - extern_record_location(v); + extern_record_location(output_location); break; } default: { @@ -596,12 +524,12 @@ static void extern_rec(value v) size_32 += 1 + sz; size_64 += 1 + sz; field0 = Field(v, 0); - extern_record_location(v); + extern_record_location(output_location); /* Remember that we still have to serialize fields 1 ... sz - 1 */ if (sz > 1) { sp++; if (sp >= extern_stack_limit) sp = extern_resize_stack(sp); - sp->v = &Field(v,1); + sp->v = &Field(v, 0) + 1; sp->count = sz-1; } /* Continue serialization with the first field */ @@ -645,17 +573,18 @@ static intnat extern_value(value v, value flags, /* Parse flag list */ extern_flags = caml_convert_flag_list(flags, extern_flag_values); /* Initializations */ - init_extern_trail(); + caml_addrmap_clear(&recorded_objs); obj_counter = 0; size_32 = 0; size_64 = 0; + caml_addrmap_initialize(&recorded_objs); /* Marshal the object */ extern_rec(v); /* Record end of output */ close_extern_output(); - /* Undo the modifications done on externed blocks */ - extern_replay_trail(); - /* Write the header */ + /* Delete the hashtable of recorded objects */ + caml_addrmap_clear(&recorded_objs); + /* Write the sizes */ res_len = extern_output_length(); #ifdef ARCH_SIXTYFOUR if (res_len >= ((intnat)1 << 32) || diff --git a/runtime/startup_aux.c b/runtime/startup_aux.c index 5db9f4803c18..2ceed15cdb3b 100644 --- a/runtime/startup_aux.c +++ b/runtime/startup_aux.c @@ -85,6 +85,7 @@ uintnat caml_init_major_window = Major_window_def; uintnat caml_init_custom_major_ratio = Custom_major_ratio_def; uintnat caml_init_custom_minor_ratio = Custom_minor_ratio_def; uintnat caml_init_custom_minor_max_bsz = Custom_minor_max_bsz_def; +uintnat caml_init_intern_addrmap_size = Init_intern_addrmap_def; extern int caml_parser_trace; uintnat caml_trace_level = 0; int caml_cleanup_on_exit = 0; @@ -116,6 +117,7 @@ void caml_parse_ocamlrunparam(void) switch (*opt++){ case 'a': scanmult (opt, &p); caml_set_allocation_policy ((intnat) p); break; + case 'A': scanmult (opt, &caml_init_intern_addrmap_size); break; case 'b': scanmult (opt, &p); caml_record_backtrace(Val_bool (p)); break; case 'c': scanmult (opt, &p); caml_cleanup_on_exit = (p != 0); break;