static void init_atoms(void)
{
extern struct segment caml_data_segments[], caml_code_segments[];
int i;
for (i = 0; i < 256; i++) {
caml_atom_table[i] = Make_header(0, i, Caml_white);
}
if (caml_page_table_add(In_static_data,
caml_atom_table, caml_atom_table + 256) != 0)
caml_fatal_error("Fatal error: not enough memory for the initial page table");
for (i = 0; caml_data_segments[i].begin != 0; i++) {
if (caml_page_table_add(In_static_data,
caml_data_segments[i].begin,
caml_data_segments[i].end) != 0)
caml_fatal_error("Fatal error: not enough memory for the initial page table");
}
caml_code_area_start = caml_code_segments[0].begin;
caml_code_area_end = caml_code_segments[0].end;
for (i = 1; caml_code_segments[i].begin != 0; i++) {
if (caml_code_segments[i].begin < caml_code_area_start)
caml_code_area_start = caml_code_segments[i].begin;
if (caml_code_segments[i].end > caml_code_area_end)
caml_code_area_end = caml_code_segments[i].end;
}
}
static struct ev_info *process_debug_events(code_t code_start, value events_heap,
mlsize_t *num_events)
{
CAMLparam1(events_heap);
CAMLlocal3(l, ev, ev_start);
mlsize_t i, j;
struct ev_info *events;
/* Compute the size of the required event buffer. */
*num_events = 0;
for (i = 0; i < caml_array_length(events_heap); i++)
for (l = Field_imm(events_heap, i); l != Val_int(0); l = Field_imm(l, 1))
(*num_events)++;
if (*num_events == 0)
CAMLreturnT(struct ev_info *, NULL);
events = caml_stat_alloc_noexc(*num_events * sizeof(struct ev_info));
if(events == NULL)
caml_fatal_error ("caml_add_debug_info: out of memory");
j = 0;
for (i = 0; i < caml_array_length(events_heap); i++) {
for (l = Field_imm(events_heap, i); l != Val_int(0); l = Field_imm(l, 1)) {
ev = Field_imm(l, 0);
events[j].ev_pc = (code_t)((char*)code_start
+ Long_val(Field_imm(ev, EV_POS)));
ev_start = Field(Field(ev, EV_LOC), LOC_START);
{
uintnat fnsz = caml_string_length(Field_imm(ev_start, POS_FNAME)) + 1;
events[j].ev_filename = (char*)caml_stat_alloc_noexc(fnsz);
if(events[j].ev_filename == NULL)
caml_fatal_error ("caml_add_debug_info: out of memory");
memcpy(events[j].ev_filename,
String_val(Field(ev_start, POS_FNAME)),
fnsz);
}
events[j].ev_lnum = Int_val(Field(ev_start, POS_LNUM));
events[j].ev_startchr =
Int_val(Field(ev_start, POS_CNUM))
- Int_val(Field(ev_start, POS_BOL));
events[j].ev_endchr =
Int_val(Field(Field(Field(ev, EV_LOC), LOC_END), POS_CNUM))
- Int_val(Field(ev_start, POS_BOL));
j++;
}
}
CAMLassert(j == *num_events);
qsort(events, *num_events, sizeof(struct ev_info), cmp_ev_info);
CAMLreturnT(struct ev_info *, events);
}
CAMLexport void caml_raise_out_of_memory(void)
{
if (out_of_memory_bucket.exn == 0)
caml_fatal_error
("Fatal error: out of memory while raising Out_of_memory\n");
caml_raise((value) &(out_of_memory_bucket.exn));
}
void caml_init_gc (uintnat minor_size, uintnat major_size,
uintnat major_incr, uintnat percent_fr,
uintnat percent_m)
{
uintnat major_heap_size = Bsize_wsize (norm_heapincr (major_size));
if (caml_page_table_initialize(Bsize_wsize(minor_size) + major_heap_size)) {
caml_fatal_error ("OCaml runtime error: cannot initialize page table\n");
}
caml_set_minor_heap_size (Bsize_wsize (norm_minsize (minor_size)));
caml_major_heap_increment = Bsize_wsize (norm_heapincr (major_incr));
caml_percent_free = norm_pfree (percent_fr);
caml_percent_max = norm_pmax (percent_m);
caml_init_major_heap (major_heap_size);
caml_gc_message (0x20, "Initial minor heap size: %luk bytes\n",
caml_minor_heap_size / 1024);
caml_gc_message (0x20, "Initial major heap size: %luk bytes\n",
major_heap_size / 1024);
caml_gc_message (0x20, "Initial space overhead: %lu%%\n", caml_percent_free);
caml_gc_message (0x20, "Initial max overhead: %lu%%\n", caml_percent_max);
caml_gc_message (0x20, "Initial heap increment: %luk bytes\n",
caml_major_heap_increment / 1024);
caml_gc_message (0x20, "Initial allocation policy: %d\n",
caml_allocation_policy);
}
void caml_realloc_ref_table (struct caml_ref_table *tbl)
{ Assert (tbl->ptr == tbl->limit);
Assert (tbl->limit <= tbl->end);
Assert (tbl->limit >= tbl->threshold);
if (tbl->base == NULL){
caml_alloc_table (tbl, caml_minor_heap_size / sizeof (value) / 8, 256);
}else if (tbl->limit == tbl->threshold){
caml_gc_message (0x08, "ref_table threshold crossed\n", 0);
tbl->limit = tbl->end;
caml_urge_major_slice ();
}else{ /* This will almost never happen with the bytecode interpreter. */
asize_t sz;
asize_t cur_ptr = tbl->ptr - tbl->base;
Assert (caml_force_major_slice);
tbl->size *= 2;
sz = (tbl->size + tbl->reserve) * sizeof (value *);
caml_gc_message (0x08, "Growing ref_table to %"
ARCH_INTNAT_PRINTF_FORMAT "dk bytes\n",
(intnat) sz/1024);
tbl->base = (value **) realloc ((char *) tbl->base, sz);
if (tbl->base == NULL){
caml_fatal_error ("Fatal error: ref_table overflow\n");
}
tbl->end = tbl->base + tbl->size + tbl->reserve;
tbl->threshold = tbl->base + tbl->size;
tbl->ptr = tbl->base + cur_ptr;
tbl->limit = tbl->end;
}
}
void caml_load_code(int fd, asize_t len)
{
/* OCamlCC: fix g++ warning */
asize_t i;
caml_code_size = len;
caml_start_code = (code_t) caml_stat_alloc(caml_code_size);
/* OCamlCC: fix g++ warning */
if (read(fd, (char *) caml_start_code, caml_code_size) !=
(ssize_t) caml_code_size)
caml_fatal_error("Fatal error: truncated bytecode file.\n");
caml_init_code_fragments();
/* Prepare the code for execution */
#ifdef ARCH_BIG_ENDIAN
caml_fixup_endianness(caml_start_code, caml_code_size);
#endif
if (caml_debugger_in_use) {
len /= sizeof(opcode_t);
caml_saved_code = (unsigned char *) caml_stat_alloc(len);
for (i = 0; i < len; i++) caml_saved_code[i] = caml_start_code[i];
}
#ifdef THREADED_CODE
/* Better to thread now than at the beginning of [caml_interprete],
since the debugger interface needs to perform SET_EVENT requests
on the code. */
caml_thread_code(caml_start_code, caml_code_size);
#endif
}
static void realloc_generic_table
(struct generic_table *tbl, asize_t element_size,
char * msg_intr_int, char *msg_threshold, char *msg_growing, char *msg_error)
{
CAMLassert (tbl->ptr == tbl->limit);
CAMLassert (tbl->limit <= tbl->end);
CAMLassert (tbl->limit >= tbl->threshold);
if (tbl->base == NULL){
alloc_generic_table (tbl, Caml_state->minor_heap_wsz / 8, 256,
element_size);
}else if (tbl->limit == tbl->threshold){
CAML_INSTR_INT (msg_intr_int, 1);
caml_gc_message (0x08, msg_threshold, 0);
tbl->limit = tbl->end;
caml_urge_major_slice ();
}else{
asize_t sz;
asize_t cur_ptr = tbl->ptr - tbl->base;
tbl->size *= 2;
sz = (tbl->size + tbl->reserve) * element_size;
caml_gc_message (0x08, msg_growing, (intnat) sz/1024);
tbl->base = caml_stat_resize_noexc (tbl->base, sz);
if (tbl->base == NULL){
caml_fatal_error (msg_error);
}
tbl->end = tbl->base + (tbl->size + tbl->reserve) * element_size;
tbl->threshold = tbl->base + tbl->size * element_size;
tbl->ptr = tbl->base + cur_ptr;
tbl->limit = tbl->end;
}
}
void caml_debugger_init(void)
{
char * address;
char * port, * p;
struct hostent * host;
int n;
caml_register_global_root(&marshal_flags);
marshal_flags = caml_alloc(2, Tag_cons);
Store_field(marshal_flags, 0, Val_int(1)); /* Marshal.Closures */
Store_field(marshal_flags, 1, Val_emptylist);
address = getenv("CAML_DEBUG_SOCKET");
if (address == NULL) return;
dbg_addr = address;
#ifdef _WIN32
winsock_startup();
(void)atexit(winsock_cleanup);
#endif
/* Parse the address */
port = NULL;
for (p = address; *p != 0; p++) {
if (*p == ':') { *p = 0; port = p+1; break; }
}
if (port == NULL) {
#ifndef _WIN32
/* Unix domain */
sock_domain = PF_UNIX;
sock_addr.s_unix.sun_family = AF_UNIX;
strncpy(sock_addr.s_unix.sun_path, address,
sizeof(sock_addr.s_unix.sun_path));
sock_addr_len =
((char *)&(sock_addr.s_unix.sun_path) - (char *)&(sock_addr.s_unix))
+ strlen(address);
#else
caml_fatal_error("Unix sockets not supported");
#endif
} else {
/* Internet domain */
sock_domain = PF_INET;
for (p = (char *) &sock_addr.s_inet, n = sizeof(sock_addr.s_inet);
n > 0; n--) *p++ = 0;
sock_addr.s_inet.sin_family = AF_INET;
sock_addr.s_inet.sin_addr.s_addr = inet_addr(address);
if (sock_addr.s_inet.sin_addr.s_addr == -1) {
host = gethostbyname(address);
if (host == NULL)
caml_fatal_error_arg("Unknown debugging host %s\n", address);
memmove(&sock_addr.s_inet.sin_addr, host->h_addr, host->h_length);
}
sock_addr.s_inet.sin_port = htons(atoi(port));
sock_addr_len = sizeof(sock_addr.s_inet);
}
open_connection();
caml_debugger_in_use = 1;
caml_trap_barrier = caml_stack_high;
}
void caml_init_domains(uintnat minor_size) {
int i;
uintnat size;
void* heaps_base;
/* sanity check configuration */
if (caml_mem_round_up_pages(1 << Minor_heap_align_bits) != (1 << Minor_heap_align_bits))
caml_fatal_error("Minor_heap_align_bits misconfigured for this platform");
/* reserve memory space for minor heaps */
size = (uintnat)1 << (Minor_heap_sel_bits + Minor_heap_align_bits);
/* To ensure Is_foreign gives no false positives, we reserve twice
the address space needed and only use the first half */
heaps_base = caml_mem_map(size*2, size*2, 1 /* reserve_only */);
if (!heaps_base) caml_raise_out_of_memory();
minor_heaps_base = (uintnat) heaps_base;
caml_plat_mutex_init(&all_domains_lock);
for (i = 0; i < Max_domains; i++) {
struct dom_internal* dom = &all_domains[i];
caml_plat_mutex_init(&dom->roots_lock);
dom->running = 0;
dom->state.id = i;
dom->tls_area = minor_heaps_base +
(uintnat)(1 << Minor_heap_align_bits) * (uintnat)i;
dom->tls_area_end =
caml_mem_round_up_pages(dom->tls_area +
sizeof(struct caml_domain_state));
dom->minor_heap_area = /* skip guard page */
caml_mem_round_up_pages(dom->tls_area_end + 1);
dom->minor_heap_area_end =
dom->minor_heap_area + (1 << Minor_heap_align_bits);
}
create_domain(minor_size, 1);
if (!domain_self) caml_fatal_error("Failed to create main domain");
caml_init_global_roots();
caml_init_signal_handling();
}
static void init_atoms(void)
{
int i;
for(i = 0; i < 256; i++) caml_atom_table[i] = Make_header(0, i, Caml_white);
if (caml_page_table_add(In_static_data,
caml_atom_table, caml_atom_table + 256) != 0) {
caml_fatal_error("Fatal error: not enough memory for the initial page table");
}
}
static value alloc_shared(mlsize_t wosize, tag_t tag)
{
void* mem = caml_shared_try_alloc(caml_domain_self()->shared_heap, wosize, tag, 0 /* not promotion */);
caml_domain_state->allocated_words += Whsize_wosize(wosize);
if (mem == NULL) {
caml_fatal_error("allocation failure during minor GC");
}
return Val_hp(mem);
}
static value caml_promote_one(struct promotion_stack* stk, struct domain* domain, value curr)
{
header_t curr_block_hd;
int infix_offset = 0;
if (Is_long(curr) || !Is_minor(curr))
return curr; /* needs no promotion */
Assert(caml_owner_of_young_block(curr) == domain);
curr_block_hd = Hd_val(curr);
if (Tag_hd(curr_block_hd) == Infix_tag) {
infix_offset = Infix_offset_val(curr);
curr -= infix_offset;
curr_block_hd = Hd_val(curr);
}
if (Is_promoted_hd(curr_block_hd)) {
/* already promoted */
return caml_addrmap_lookup(&domain->state->remembered_set->promotion, curr) + infix_offset;
} else if (curr_block_hd == 0) {
/* promoted by minor GC */
return Op_val(curr)[0] + infix_offset;
}
/* otherwise, must promote */
void* mem = caml_shared_try_alloc(domain->shared_heap, Wosize_hd(curr_block_hd),
Tag_hd(curr_block_hd), 1);
if (!mem) caml_fatal_error("allocation failure during promotion");
value promoted = Val_hp(mem);
Hd_val(curr) = Promotedhd_hd(curr_block_hd);
caml_addrmap_insert(&domain->state->remembered_set->promotion, curr, promoted);
caml_addrmap_insert(&domain->state->remembered_set->promotion_rev, promoted, curr);
if (Tag_hd(curr_block_hd) >= No_scan_tag) {
int i;
for (i = 0; i < Wosize_hd(curr_block_hd); i++)
Op_val(promoted)[i] = Op_val(curr)[i];
} else {
/* push to stack */
if (stk->sp == stk->stack_len) {
stk->stack_len = 2 * (stk->stack_len + 10);
stk->stack = caml_stat_resize(stk->stack,
sizeof(struct promotion_stack_entry) * stk->stack_len);
}
stk->stack[stk->sp].local = curr;
stk->stack[stk->sp].global = promoted;
stk->stack[stk->sp].field = 0;
stk->sp++;
}
return promoted + infix_offset;
}
static void read_main_debug_info(struct debug_info *di)
{
CAMLparam0();
CAMLlocal3(events, evl, l);
char_os *exec_name;
int fd, num_events, orig, i;
struct channel *chan;
struct exec_trailer trail;
CAMLassert(di->already_read == 0);
di->already_read = 1;
if (caml_params->cds_file != NULL) {
exec_name = (char_os*) caml_params->cds_file;
} else {
exec_name = (char_os*) caml_params->exe_name;
}
fd = caml_attempt_open(&exec_name, &trail, 1);
if (fd < 0){
caml_fatal_error ("executable program file not found");
CAMLreturn0;
}
caml_read_section_descriptors(fd, &trail);
if (caml_seek_optional_section(fd, &trail, "DBUG") != -1) {
chan = caml_open_descriptor_in(fd);
num_events = caml_getword(chan);
events = caml_alloc(num_events, 0);
for (i = 0; i < num_events; i++) Op_val(events)[i] = Val_unit;
for (i = 0; i < num_events; i++) {
orig = caml_getword(chan);
evl = caml_input_val(chan);
caml_input_val(chan); /* Skip the list of absolute directory names */
/* Relocate events in event list */
for (l = evl; l != Val_int(0); l = Field_imm(l, 1)) {
value ev = Field_imm(l, 0);
Store_field (ev, EV_POS, Val_long(Long_val(Field(ev, EV_POS)) + orig));
}
/* Record event list */
Store_field(events, i, evl);
}
caml_close_channel(chan);
di->events = process_debug_events(caml_start_code, events, &di->num_events);
}
CAMLreturn0;
}
void caml_read_section_descriptors(int fd, struct exec_trailer *trail)
{
int toc_size, i;
toc_size = trail->num_sections * 8;
trail->section = caml_stat_alloc(toc_size);
lseek(fd, - (long) (TRAILER_SIZE + toc_size), SEEK_END);
if (read(fd, (char *) trail->section, toc_size) != toc_size)
caml_fatal_error("Fatal error: cannot read section table\n");
/* Fixup endianness of lengths */
for (i = 0; i < trail->num_sections; i++)
fixup_endianness_trailer(&(trail->section[i].len));
}
/* [minor_size] and [major_size] are numbers of words
[major_incr] is either a percentage or a number of words */
void caml_init_gc (uintnat minor_size, uintnat major_size,
uintnat major_incr, uintnat percent_fr,
uintnat percent_m, uintnat window)
{
uintnat major_heap_size =
Bsize_wsize (caml_normalize_heap_increment (major_size));
CAML_INSTR_INIT ();
if (caml_init_alloc_for_heap () != 0){
caml_fatal_error ("cannot initialize heap: mmap failed\n");
}
if (caml_page_table_initialize(Bsize_wsize(minor_size) + major_heap_size)){
caml_fatal_error ("OCaml runtime error: cannot initialize page table\n");
}
caml_set_minor_heap_size (Bsize_wsize (norm_minsize (minor_size)));
caml_major_heap_increment = major_incr;
caml_percent_free = norm_pfree (percent_fr);
caml_percent_max = norm_pmax (percent_m);
caml_init_major_heap (major_heap_size);
caml_major_window = norm_window (window);
caml_gc_message (0x20, "Initial minor heap size: %luk words\n",
caml_minor_heap_wsz / 1024);
caml_gc_message (0x20, "Initial major heap size: %luk bytes\n",
major_heap_size / 1024);
caml_gc_message (0x20, "Initial space overhead: %lu%%\n", caml_percent_free);
caml_gc_message (0x20, "Initial max overhead: %lu%%\n", caml_percent_max);
if (caml_major_heap_increment > 1000){
caml_gc_message (0x20, "Initial heap increment: %luk words\n",
caml_major_heap_increment / 1024);
}else{
caml_gc_message (0x20, "Initial heap increment: %lu%%\n",
caml_major_heap_increment);
}
caml_gc_message (0x20, "Initial allocation policy: %d\n",
caml_allocation_policy);
caml_gc_message (0x20, "Initial smoothing window: %d\n",
caml_major_window);
}
static void init_atoms(void)
{
extern struct segment caml_data_segments[], caml_code_segments[];
int i;
struct code_fragment * cf;
for (i = 0; i < 256; i++) {
caml_atom_table[i] = Make_header(0, i, Caml_white);
}
if (caml_page_table_add(In_static_data,
caml_atom_table, caml_atom_table + 256) != 0)
caml_fatal_error("Fatal error: not enough memory for initial page table");
for (i = 0; caml_data_segments[i].begin != 0; i++) {
/* PR#5509: we must include the zero word at end of data segment,
because pointers equal to caml_data_segments[i].end are static data. */
if (caml_page_table_add(In_static_data,
caml_data_segments[i].begin,
caml_data_segments[i].end + sizeof(value)) != 0)
caml_fatal_error("Fatal error: not enough memory for initial page table");
}
caml_code_area_start = caml_code_segments[0].begin;
caml_code_area_end = caml_code_segments[0].end;
for (i = 1; caml_code_segments[i].begin != 0; i++) {
if (caml_code_segments[i].begin < caml_code_area_start)
caml_code_area_start = caml_code_segments[i].begin;
if (caml_code_segments[i].end > caml_code_area_end)
caml_code_area_end = caml_code_segments[i].end;
}
/* Register the code in the table of code fragments */
cf = caml_stat_alloc(sizeof(struct code_fragment));
cf->code_start = caml_code_area_start;
cf->code_end = caml_code_area_end;
cf->digest_computed = 0;
caml_ext_table_init(&caml_code_fragments_table, 8);
caml_ext_table_add(&caml_code_fragments_table, cf);
}
void caml_plat_assert_locked(caml_plat_mutex* m)
{
#ifdef DEBUG
int r = pthread_mutex_trylock(m);
if (r == EBUSY) {
/* ok, it was locked */
return;
} else if (r == 0) {
caml_fatal_error("Required mutex not locked");
} else {
check_err("assert_locked", r);
}
#endif
}
CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag)
{
header_t *hp;
value *new_block;
if (wosize > Max_wosize) caml_raise_out_of_memory ();
hp = caml_fl_allocate (wosize);
if (hp == NULL){
new_block = expand_heap (wosize);
if (new_block == NULL) {
if (caml_in_minor_collection)
caml_fatal_error ("Fatal error: out of memory.\n");
else
caml_raise_out_of_memory ();
}
caml_fl_add_blocks ((value) new_block);
hp = caml_fl_allocate (wosize);
}
Assert (Is_in_heap (Val_hp (hp)));
/* Inline expansion of caml_allocation_color. */
if (caml_gc_phase == Phase_mark
|| (caml_gc_phase == Phase_sweep && (addr)hp >= (addr)caml_gc_sweep_hp)){
Hd_hp (hp) = Make_header (wosize, tag, Caml_black);
}else{
Assert (caml_gc_phase == Phase_idle
|| (caml_gc_phase == Phase_sweep
&& (addr)hp < (addr)caml_gc_sweep_hp));
Hd_hp (hp) = Make_header (wosize, tag, Caml_white);
}
Assert (Hd_hp (hp) == Make_header (wosize, tag, caml_allocation_color (hp)));
caml_allocated_words += Whsize_wosize (wosize);
if (caml_allocated_words > caml_minor_heap_wsz){
caml_urge_major_slice ();
}
#ifdef DEBUG
{
uintnat i;
for (i = 0; i < wosize; i++){
Field (Val_hp (hp), i) = Debug_uninit_major;
}
}
#endif
return Val_hp (hp);
}
int caml_startup_aux(int pooling)
{
if (shutdown_happened == 1)
caml_fatal_error("Fatal error: caml_startup was called after the runtime "
"was shut down with caml_shutdown");
/* Second and subsequent calls are ignored,
since the runtime has already started */
startup_count++;
if (startup_count > 1)
return 0;
if (pooling)
caml_stat_create_pool();
return 1;
}
/* [sz] and [rsv] are numbers of entries */
static void alloc_generic_table (struct generic_table *tbl, asize_t sz,
asize_t rsv, asize_t element_size)
{
void *new_table;
tbl->size = sz;
tbl->reserve = rsv;
new_table = (void *) caml_stat_alloc_noexc((tbl->size + tbl->reserve) *
element_size);
if (new_table == NULL) caml_fatal_error ("Fatal error: not enough memory\n");
if (tbl->base != NULL) caml_stat_free (tbl->base);
tbl->base = new_table;
tbl->ptr = tbl->base;
tbl->threshold = tbl->base + tbl->size * element_size;
tbl->limit = tbl->threshold;
tbl->end = tbl->base + (tbl->size + tbl->reserve) * element_size;
}
static void open_connection(void)
{
#ifdef _WIN32
/* Set socket to synchronous mode so that file descriptor-oriented
functions (read()/write() etc.) can be used */
int oldvalue, oldvaluelen, newvalue, retcode;
oldvaluelen = sizeof(oldvalue);
retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
(char *) &oldvalue, &oldvaluelen);
if (retcode == 0) {
newvalue = SO_SYNCHRONOUS_NONALERT;
setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
(char *) &newvalue, sizeof(newvalue));
}
#endif
dbg_socket = socket(sock_domain, SOCK_STREAM, 0);
#ifdef _WIN32
if (retcode == 0) {
/* Restore initial mode */
setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
(char *) &oldvalue, oldvaluelen);
}
#endif
if (dbg_socket == -1 ||
connect(dbg_socket, &sock_addr.s_gen, sock_addr_len) == -1){
caml_fatal_error_arg2 ("cannot connect to debugger at %s\n", dbg_addr,
"error: %s\n", strerror (errno));
}
#ifdef _WIN32
dbg_socket = _open_osfhandle(dbg_socket, 0);
if (dbg_socket == -1)
caml_fatal_error("_open_osfhandle failed");
#endif
dbg_in = caml_open_descriptor_in(dbg_socket);
dbg_out = caml_open_descriptor_out(dbg_socket);
if (!caml_debugger_in_use) caml_putword(dbg_out, -1); /* first connection */
#ifdef _WIN32
caml_putword(dbg_out, _getpid());
#else
caml_putword(dbg_out, getpid());
#endif
caml_flush(dbg_out);
}
CAMLexport void caml_shutdown(void)
{
if (startup_count <= 0)
caml_fatal_error("Fatal error: a call to caml_shutdown has no "
"corresponding call to caml_startup");
/* Do nothing unless it's the last call remaining */
startup_count--;
if (startup_count > 0)
return;
call_registered_value("Pervasives.do_at_exit");
call_registered_value("Thread.at_shutdown");
caml_finalise_heap();
#ifndef NATIVE_CODE
caml_free_shared_libs();
#endif
caml_stat_destroy_pool();
shutdown_happened = 1;
}
static value promote_stack(struct domain* domain, value stack)
{
caml_gc_log("Promoting stack");
Assert(Tag_val(stack) == Stack_tag);
if (Is_minor(stack)) {
/* First, promote the actual stack object */
Assert(caml_owner_of_young_block(stack) == domain);
/* Stacks are only referenced via fibers, so we don't bother
using the promotion_table */
void* new_stack = caml_shared_try_alloc(domain->shared_heap, Wosize_val(stack), Stack_tag, 0);
if (!new_stack) caml_fatal_error("allocation failure during stack promotion");
memcpy(Op_hp(new_stack), (void*)stack, Wosize_val(stack) * sizeof(value));
stack = Val_hp(new_stack);
}
/* Promote each object on the stack. */
promote_domain = domain;
caml_scan_stack(&promote_stack_elem, stack);
/* Since we've promoted the objects on the stack, the stack is now clean. */
caml_clean_stack_domain(stack, domain);
return stack;
}
void caml_debugger(enum event_kind event)
{
int frame_number;
value * frame;
intnat i, pos;
value val;
if (dbg_socket == -1) return; /* Not connected to a debugger. */
/* Reset current frame */
frame_number = 0;
frame = caml_extern_sp + 1;
/* Report the event to the debugger */
switch(event) {
case PROGRAM_START: /* Nothing to report */
goto command_loop;
case EVENT_COUNT:
putch(dbg_out, REP_EVENT);
break;
case BREAKPOINT:
putch(dbg_out, REP_BREAKPOINT);
break;
case PROGRAM_EXIT:
putch(dbg_out, REP_EXITED);
break;
case TRAP_BARRIER:
putch(dbg_out, REP_TRAP);
break;
case UNCAUGHT_EXC:
putch(dbg_out, REP_UNCAUGHT_EXC);
break;
}
caml_putword(dbg_out, caml_event_count);
if (event == EVENT_COUNT || event == BREAKPOINT) {
caml_putword(dbg_out, caml_stack_high - frame);
caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t));
} else {
/* No PC and no stack frame associated with other events */
caml_putword(dbg_out, 0);
caml_putword(dbg_out, 0);
}
caml_flush(dbg_out);
command_loop:
/* Read and execute the commands sent by the debugger */
while(1) {
switch(getch(dbg_in)) {
case REQ_SET_EVENT:
pos = caml_getword(dbg_in);
Assert (pos >= 0);
Assert (pos < caml_code_size);
caml_set_instruction(caml_start_code + pos / sizeof(opcode_t), EVENT);
break;
case REQ_SET_BREAKPOINT:
pos = caml_getword(dbg_in);
Assert (pos >= 0);
Assert (pos < caml_code_size);
caml_set_instruction(caml_start_code + pos / sizeof(opcode_t), BREAK);
break;
case REQ_RESET_INSTR:
pos = caml_getword(dbg_in);
Assert (pos >= 0);
Assert (pos < caml_code_size);
pos = pos / sizeof(opcode_t);
caml_set_instruction(caml_start_code + pos, caml_saved_code[pos]);
break;
case REQ_CHECKPOINT:
#ifndef _WIN32
i = fork();
if (i == 0) {
close_connection(); /* Close parent connection. */
open_connection(); /* Open new connection with debugger */
} else {
caml_putword(dbg_out, i);
caml_flush(dbg_out);
}
#else
caml_fatal_error("error: REQ_CHECKPOINT command");
exit(-1);
#endif
break;
case REQ_GO:
caml_event_count = caml_getword(dbg_in);
return;
case REQ_STOP:
exit(0);
break;
case REQ_WAIT:
#ifndef _WIN32
wait(NULL);
#else
caml_fatal_error("Fatal error: REQ_WAIT command");
exit(-1);
#endif
break;
case REQ_INITIAL_FRAME:
frame = caml_extern_sp + 1;
/* Fall through */
case REQ_GET_FRAME:
caml_putword(dbg_out, caml_stack_high - frame);
if (frame < caml_stack_high){
caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t));
}else{
caml_putword (dbg_out, 0);
}
caml_flush(dbg_out);
break;
case REQ_SET_FRAME:
i = caml_getword(dbg_in);
frame = caml_stack_high - i;
break;
case REQ_UP_FRAME:
i = caml_getword(dbg_in);
if (frame + Extra_args(frame) + i + 3 >= caml_stack_high) {
caml_putword(dbg_out, -1);
} else {
frame += Extra_args(frame) + i + 3;
caml_putword(dbg_out, caml_stack_high - frame);
caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t));
}
caml_flush(dbg_out);
break;
case REQ_SET_TRAP_BARRIER:
i = caml_getword(dbg_in);
caml_trap_barrier = caml_stack_high - i;
break;
case REQ_GET_LOCAL:
i = caml_getword(dbg_in);
putval(dbg_out, Locals(frame)[i]);
caml_flush(dbg_out);
break;
case REQ_GET_ENVIRONMENT:
i = caml_getword(dbg_in);
putval(dbg_out, Field(Env(frame), i));
caml_flush(dbg_out);
break;
case REQ_GET_GLOBAL:
i = caml_getword(dbg_in);
putval(dbg_out, Field(caml_global_data, i));
caml_flush(dbg_out);
break;
case REQ_GET_ACCU:
putval(dbg_out, *caml_extern_sp);
caml_flush(dbg_out);
break;
case REQ_GET_HEADER:
val = getval(dbg_in);
caml_putword(dbg_out, Hd_val(val));
caml_flush(dbg_out);
break;
case REQ_GET_FIELD:
val = getval(dbg_in);
i = caml_getword(dbg_in);
if (Tag_val(val) != Double_array_tag) {
putch(dbg_out, 0);
putval(dbg_out, Field(val, i));
} else {
double d = Double_field(val, i);
putch(dbg_out, 1);
caml_really_putblock(dbg_out, (char *) &d, 8);
}
caml_flush(dbg_out);
break;
case REQ_MARSHAL_OBJ:
val = getval(dbg_in);
safe_output_value(dbg_out, val);
caml_flush(dbg_out);
break;
case REQ_GET_CLOSURE_CODE:
val = getval(dbg_in);
caml_putword(dbg_out, (Code_val(val)-caml_start_code) * sizeof(opcode_t));
caml_flush(dbg_out);
break;
case REQ_SET_FORK_MODE:
caml_debugger_fork_mode = caml_getword(dbg_in);
break;
}
}
}
static void winsock_startup(void)
{
WSADATA wsaData;
int err = WSAStartup(MAKEWORD(2, 0), &wsaData);
if (err) caml_fatal_error("WSAStartup failed");
}
/* The bytecode interpreter for the NFA */
static int re_match(value re,
unsigned char * starttxt,
register unsigned char * txt,
register unsigned char * endtxt,
int accept_partial_match)
{
register value * pc;
intnat instr;
struct backtrack_stack * stack;
union backtrack_point * sp;
value cpool;
value normtable;
unsigned char c;
union backtrack_point back;
{ int i;
struct re_group * p;
unsigned char ** q;
for (p = &re_group[1], i = Numgroups(re); i > 1; i--, p++)
p->start = p->end = NULL;
for (q = &re_register[0], i = Numregisters(re); i > 0; i--, q++)
*q = NULL;
}
pc = &Field(Prog(re), 0);
stack = &initial_stack;
sp = stack->point;
cpool = Cpool(re);
normtable = Normtable(re);
re_group[0].start = txt;
while (1) {
instr = Long_val(*pc++);
switch (Opcode(instr)) {
case CHAR:
if (txt == endtxt) goto prefix_match;
if (*txt != Arg(instr)) goto backtrack;
txt++;
break;
case CHARNORM:
if (txt == endtxt) goto prefix_match;
if (Byte_u(normtable, *txt) != Arg(instr)) goto backtrack;
txt++;
break;
case STRING: {
unsigned char * s =
(unsigned char *) String_val(Field(cpool, Arg(instr)));
while ((c = *s++) != 0) {
if (txt == endtxt) goto prefix_match;
if (c != *txt) goto backtrack;
txt++;
}
break;
}
case STRINGNORM: {
unsigned char * s =
(unsigned char *) String_val(Field(cpool, Arg(instr)));
while ((c = *s++) != 0) {
if (txt == endtxt) goto prefix_match;
if (c != Byte_u(normtable, *txt)) goto backtrack;
txt++;
}
break;
}
case CHARCLASS:
if (txt == endtxt) goto prefix_match;
if (! In_bitset(String_val(Field(cpool, Arg(instr))), *txt, c))
goto backtrack;
txt++;
break;
case BOL:
if (txt > starttxt && txt[-1] != '\n') goto backtrack;
break;
case EOL:
if (txt < endtxt && *txt != '\n') goto backtrack;
break;
case WORDBOUNDARY:
/* At beginning and end of text: no
At beginning of text: OK if current char is a letter
At end of text: OK if previous char is a letter
Otherwise:
OK if previous char is a letter and current char not a letter
or previous char is not a letter and current char is a letter */
if (txt == starttxt) {
if (txt == endtxt) goto prefix_match;
if (Is_word_letter(txt[0])) break;
goto backtrack;
} else if (txt == endtxt) {
if (Is_word_letter(txt[-1])) break;
goto backtrack;
} else {
if (Is_word_letter(txt[-1]) != Is_word_letter(txt[0])) break;
goto backtrack;
}
case BEGGROUP: {
int group_no = Arg(instr);
struct re_group * group = &(re_group[group_no]);
back.undo.loc = &(group->start);
back.undo.val = group->start;
group->start = txt;
goto push;
}
case ENDGROUP: {
int group_no = Arg(instr);
struct re_group * group = &(re_group[group_no]);
back.undo.loc = &(group->end);
back.undo.val = group->end;
group->end = txt;
goto push;
}
case REFGROUP: {
int group_no = Arg(instr);
struct re_group * group = &(re_group[group_no]);
unsigned char * s;
if (group->start == NULL || group->end == NULL) goto backtrack;
for (s = group->start; s < group->end; s++) {
if (txt == endtxt) goto prefix_match;
if (*s != *txt) goto backtrack;
txt++;
}
break;
}
case ACCEPT:
goto accept;
case SIMPLEOPT: {
char * set = String_val(Field(cpool, Arg(instr)));
if (txt < endtxt && In_bitset(set, *txt, c)) txt++;
break;
}
case SIMPLESTAR: {
char * set = String_val(Field(cpool, Arg(instr)));
while (txt < endtxt && In_bitset(set, *txt, c))
txt++;
break;
}
case SIMPLEPLUS: {
char * set = String_val(Field(cpool, Arg(instr)));
if (txt == endtxt) goto prefix_match;
if (! In_bitset(set, *txt, c)) goto backtrack;
txt++;
while (txt < endtxt && In_bitset(set, *txt, c))
txt++;
break;
}
case GOTO:
pc = pc + SignedArg(instr);
break;
case PUSHBACK:
back.pos.pc = Set_tag(pc + SignedArg(instr));
back.pos.txt = txt;
goto push;
case SETMARK: {
int reg_no = Arg(instr);
unsigned char ** reg = &(re_register[reg_no]);
back.undo.loc = reg;
back.undo.val = *reg;
*reg = txt;
goto push;
}
case CHECKPROGRESS: {
int reg_no = Arg(instr);
if (re_register[reg_no] == txt)
goto backtrack;
break;
}
default:
caml_fatal_error ("impossible case in re_match");
}
/* Continue with next instruction */
continue;
push:
/* Push an item on the backtrack stack and continue with next instr */
if (sp == stack->point + BACKTRACK_STACK_BLOCK_SIZE) {
struct backtrack_stack * newstack =
caml_stat_alloc(sizeof(struct backtrack_stack));
newstack->previous = stack;
stack = newstack;
sp = stack->point;
}
*sp = back;
sp++;
continue;
prefix_match:
/* We get here when matching failed because the end of text
was encountered. */
if (accept_partial_match) goto accept;
backtrack:
/* We get here when matching fails. Backtrack to most recent saved
program point, undoing variable assignments on the way. */
while (1) {
if (sp == stack->point) {
struct backtrack_stack * prevstack = stack->previous;
if (prevstack == NULL) return 0;
caml_stat_free(stack);
stack = prevstack;
sp = stack->point + BACKTRACK_STACK_BLOCK_SIZE;
}
sp--;
if (Tag_is_set(sp->pos.pc)) {
pc = Clear_tag(sp->pos.pc);
txt = sp->pos.txt;
break;
} else {
*(sp->undo.loc) = sp->undo.val;
}
}
continue;
}
accept:
/* We get here when the regexp was successfully matched */
free_backtrack_stack(stack);
re_group[0].end = txt;
return 1;
}
static void mark_stack_push(value v) {
Assert(Is_block(v));
if (caml_domain_state->mark_stack_count >= MARK_STACK_SIZE)
caml_fatal_error("mark stack overflow");
caml_domain_state->mark_stack[caml_domain_state->mark_stack_count++] = v;
}
CAMLexport void caml_main(char **argv)
{
int fd, pos;
struct exec_trailer trail;
struct channel * chan;
value res;
char * shared_lib_path, * shared_libs, * req_prims;
char * exe_name;
#ifdef __linux__
static char proc_self_exe[256];
#endif
/* Machine-dependent initialization of the floating-point hardware
so that it behaves as much as possible as specified in IEEE */
caml_init_ieee_floats();
#ifdef _MSC_VER
caml_install_invalid_parameter_handler();
#endif
caml_init_custom_operations();
caml_ext_table_init(&caml_shared_libs_path, 8);
caml_external_raise = NULL;
/* Determine options and position of bytecode file */
#ifdef DEBUG
caml_verb_gc = 0xBF;
#endif
parse_camlrunparam();
pos = 0;
exe_name = argv[0];
#ifdef __linux__
if (caml_executable_name(proc_self_exe, sizeof(proc_self_exe)) == 0)
exe_name = proc_self_exe;
#endif
fd = caml_attempt_open(&exe_name, &trail, 0);
if (fd < 0) {
pos = parse_command_line(argv);
if (argv[pos] == 0)
caml_fatal_error("No bytecode file specified.\n");
exe_name = argv[pos];
fd = caml_attempt_open(&exe_name, &trail, 1);
switch(fd) {
case FILE_NOT_FOUND:
caml_fatal_error_arg("Fatal error: cannot find file '%s'\n", argv[pos]);
break;
case BAD_BYTECODE:
caml_fatal_error_arg(
"Fatal error: the file '%s' is not a bytecode executable file\n",
exe_name);
break;
}
}
/* Read the table of contents (section descriptors) */
caml_read_section_descriptors(fd, &trail);
/* Initialize the abstract machine */
caml_init_gc (minor_heap_init, heap_size_init, heap_chunk_init,
percent_free_init, max_percent_free_init);
caml_init_stack (max_stack_init);
init_atoms();
/* Initialize the interpreter */
caml_interprete(NULL, 0);
/* Initialize the debugger, if needed */
caml_debugger_init();
/* Load the code */
caml_code_size = caml_seek_section(fd, &trail, "CODE");
caml_load_code(fd, caml_code_size);
/* Build the table of primitives */
shared_lib_path = read_section(fd, &trail, "DLPT");
shared_libs = read_section(fd, &trail, "DLLS");
req_prims = read_section(fd, &trail, "PRIM");
if (req_prims == NULL) caml_fatal_error("Fatal error: no PRIM section\n");
caml_build_primitive_table(shared_lib_path, shared_libs, req_prims);
caml_stat_free(shared_lib_path);
caml_stat_free(shared_libs);
caml_stat_free(req_prims);
/* Load the globals */
caml_seek_section(fd, &trail, "DATA");
chan = caml_open_descriptor_in(fd);
caml_global_data = caml_input_val(chan);
caml_close_channel(chan); /* this also closes fd */
caml_stat_free(trail.section);
/* Ensure that the globals are in the major heap. */
caml_oldify_one (caml_global_data, &caml_global_data);
caml_oldify_mopup ();
/* Initialize system libraries */
caml_init_exceptions();
caml_sys_init(exe_name, argv + pos);
#ifdef _WIN32
/* Start a thread to handle signals */
if (getenv("CAMLSIGPIPE"))
_beginthread(caml_signal_thread, 4096, NULL);
#endif
/* Execute the program */
caml_debugger(PROGRAM_START);
res = caml_interprete(caml_start_code, caml_code_size);
if (Is_exception_result(res)) {
caml_exn_bucket = Extract_exception(res);
if (caml_debugger_in_use) {
caml_extern_sp = &caml_exn_bucket; /* The debugger needs the
exception value.*/
caml_debugger(UNCAUGHT_EXC);
}
caml_fatal_uncaught_exception(caml_exn_bucket);
}
}
