diff options
Diffstat (limited to 'byterun')
| -rw-r--r-- | byterun/Makefile | 3 | ||||
| -rw-r--r-- | byterun/alloc.h | 8 | ||||
| -rw-r--r-- | byterun/array.c | 193 | ||||
| -rw-r--r-- | byterun/callback.h | 8 | ||||
| -rw-r--r-- | byterun/custom.h | 9 | ||||
| -rw-r--r-- | byterun/fail.h | 8 | ||||
| -rw-r--r-- | byterun/floats.c | 31 | ||||
| -rw-r--r-- | byterun/intern.c | 23 | ||||
| -rw-r--r-- | byterun/intext.h | 8 | ||||
| -rw-r--r-- | byterun/memory.c | 2 | ||||
| -rw-r--r-- | byterun/memory.h | 9 | ||||
| -rw-r--r-- | byterun/mlvalues.h | 8 | ||||
| -rw-r--r-- | byterun/obj.c | 2 | ||||
| -rw-r--r-- | byterun/parsing.c | 2 | ||||
| -rw-r--r-- | byterun/printexc.c | 2 | ||||
| -rw-r--r-- | byterun/printexc.h | 8 | ||||
| -rw-r--r-- | byterun/signals.h | 8 |
17 files changed, 321 insertions, 11 deletions
diff --git a/byterun/Makefile b/byterun/Makefile index c8669710de..316f69e5c6 100644 --- a/byterun/Makefile +++ b/byterun/Makefile @@ -65,6 +65,9 @@ clean:: $(CC) -c $(CFLAGS) $(SHAREDCCCOMPOPTS) $*.pic.c rm $*.pic.c +clean:: + rm -f *.pic.c *.d.c + depend : prims.c opnames.h jumptbl.h version.h -gcc -MM $(BYTECCCOMPOPTS) *.c > .depend -gcc -MM $(BYTECCCOMPOPTS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend diff --git a/byterun/alloc.h b/byterun/alloc.h index 7e954e36ef..75dd5ec8f9 100644 --- a/byterun/alloc.h +++ b/byterun/alloc.h @@ -23,6 +23,10 @@ #include "misc.h" #include "mlvalues.h" +#ifdef __cplusplus +extern "C" { +#endif + CAMLextern value caml_alloc (mlsize_t, tag_t); CAMLextern value caml_alloc_small (mlsize_t, tag_t); CAMLextern value caml_alloc_tuple (mlsize_t); @@ -44,4 +48,8 @@ CAMLextern value caml_alloc_final (mlsize_t, /*size in words*/ CAMLextern int caml_convert_flag_list (value, int *); +#ifdef __cplusplus +} +#endif + #endif /* CAML_ALLOC_H */ diff --git a/byterun/array.c b/byterun/array.c index ec609d04ba..637fe9c804 100644 --- a/byterun/array.c +++ b/byterun/array.c @@ -1,6 +1,6 @@ /***********************************************************************/ /* */ -/* OCaml */ +/* OCaml */ /* */ /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ /* */ @@ -15,20 +15,23 @@ /* Operations on arrays */ +#include <string.h> #include "alloc.h" #include "fail.h" #include "memory.h" #include "misc.h" #include "mlvalues.h" -CAMLexport mlsize_t caml_array_length(value array){ - tag_t tag = Tag_val(array); - if (tag == Double_array_tag) +CAMLexport mlsize_t caml_array_length(value array) +{ + if (Tag_val(array) == Double_array_tag) return Wosize_val(array) / Double_wosize; - else return Wosize_val(array); + else + return Wosize_val(array); } -CAMLexport int caml_is_double_array(value array){ +CAMLexport int caml_is_double_array(value array) +{ return (Tag_val(array) == Double_array_tag); } @@ -202,3 +205,181 @@ CAMLprim value caml_make_array(value init) } } } + +/* Blitting */ + +CAMLprim value caml_array_blit(value a1, value ofs1, value a2, value ofs2, + value n) +{ + value * src, * dst; + intnat count; + + if (Tag_val(a2) == Double_array_tag) { + /* Arrays of floats. The values being copied are floats, not + pointer, so we can do a direct copy. memmove takes care of + potential overlap between the copied areas. */ + memmove((double *)a2 + Long_val(ofs2), + (double *)a1 + Long_val(ofs1), + Long_val(n) * sizeof(double)); + return Val_unit; + } + if (Is_young(a2)) { + /* Arrays of values, destination is in young generation. + Here too we can do a direct copy since this cannot create + old-to-young pointers, nor mess up with the incremental major GC. + Again, memmove takes care of overlap. */ + memmove(&Field(a2, Long_val(ofs2)), + &Field(a1, Long_val(ofs1)), + Long_val(n) * sizeof(value)); + return Val_unit; + } + /* Array of values, destination is in old generation. + We must use caml_modify. */ + count = Long_val(n); + if (a1 == a2 && Long_val(ofs1) < Long_val(ofs2)) { + /* Copy in descending order */ + for (dst = &Field(a2, Long_val(ofs2) + count - 1), + src = &Field(a1, Long_val(ofs1) + count - 1); + count > 0; + count--, src--, dst--) { + caml_modify(dst, *src); + } + } else { + /* Copy in ascending order */ + for (dst = &Field(a2, Long_val(ofs2)), src = &Field(a1, Long_val(ofs1)); + count > 0; + count--, src++, dst++) { + caml_modify(dst, *src); + } + } + /* Many caml_modify in a row can create a lot of old-to-young refs. + Give the minor GC a chance to run if it needs to. */ + caml_check_urgent_gc(Val_unit); + return Val_unit; +} + +/* A generic function for extraction and concatenation of sub-arrays */ + +static value caml_array_gather(intnat num_arrays, + value arrays[/*num_arrays*/], + intnat offsets[/*num_arrays*/], + intnat lengths[/*num_arrays*/]) +{ + CAMLparamN(arrays, num_arrays); + value res; /* no need to register it as a root */ + int isfloat; + mlsize_t i, size, wsize, count, pos; + value * src; + + /* Determine total size and whether result array is an array of floats */ + size = 0; + isfloat = 0; + for (i = 0; i < num_arrays; i++) { + size += lengths[i]; + if (Tag_val(arrays[i]) == Double_array_tag) isfloat = 1; + } + if (size == 0) { + /* If total size = 0, just return empty array */ + res = Atom(0); + } + else if (isfloat) { + /* This is an array of floats. We can use memcpy directly. */ + wsize = size * Double_wosize; + if (wsize > Max_wosize) caml_invalid_argument("Array.concat"); + res = caml_alloc(wsize, Double_array_tag); + for (i = 0, pos = 0; i < num_arrays; i++) { + memcpy((double *)res + pos, + (double *)arrays[i] + offsets[i], + lengths[i] * sizeof(double)); + pos += lengths[i]; + } + Assert(pos == size); + } + else if (size > Max_wosize) { + /* Array of values, too big. */ + caml_invalid_argument("Array.concat"); + } + else if (size < Max_young_wosize) { + /* Array of values, small enough to fit in young generation. + We can use memcpy directly. */ + res = caml_alloc_small(size, 0); + for (i = 0, pos = 0; i < num_arrays; i++) { + memcpy(&Field(res, pos), + &Field(arrays[i], offsets[i]), + lengths[i] * sizeof(value)); + pos += lengths[i]; + } + Assert(pos == size); + } else { + /* Array of values, must be allocated in old generation and filled + using caml_initialize. */ + res = caml_alloc_shr(size, 0); + pos = 0; + for (i = 0, pos = 0; i < num_arrays; i++) { + for (src = &Field(arrays[i], offsets[i]), count = lengths[i]; + count > 0; + count--, src++, pos++) { + caml_initialize(&Field(res, pos), *src); + } + /* Many caml_initialize in a row can create a lot of old-to-young + refs. Give the minor GC a chance to run if it needs to. */ + res = caml_check_urgent_gc(res); + } + Assert(pos == size); + } + CAMLreturn (res); +} + +CAMLprim value caml_array_sub(value a, value ofs, value len) +{ + value arrays[1] = { a }; + intnat offsets[1] = { Long_val(ofs) }; + intnat lengths[1] = { Long_val(len) }; + return caml_array_gather(1, arrays, offsets, lengths); +} + +CAMLprim value caml_array_append(value a1, value a2) +{ + value arrays[2] = { a1, a2 }; + intnat offsets[2] = { 0, 0 }; + intnat lengths[2] = { caml_array_length(a1), caml_array_length(a2) }; + return caml_array_gather(2, arrays, offsets, lengths); +} + +CAMLprim value caml_array_concat(value al) +{ +#define STATIC_SIZE 16 + value static_arrays[STATIC_SIZE], * arrays; + intnat static_offsets[STATIC_SIZE], * offsets; + intnat static_lengths[STATIC_SIZE], * lengths; + intnat n, i; + value l, res; + + /* Length of list = number of arrays */ + for (n = 0, l = al; l != Val_int(0); l = Field(l, 1)) n++; + /* Allocate extra storage if too many arrays */ + if (n <= STATIC_SIZE) { + arrays = static_arrays; + offsets = static_offsets; + lengths = static_lengths; + } else { + arrays = caml_stat_alloc(n * sizeof(value)); + offsets = caml_stat_alloc(n * sizeof(intnat)); + lengths = caml_stat_alloc(n * sizeof(value)); + } + /* Build the parameters to caml_array_gather */ + for (i = 0, l = al; l != Val_int(0); l = Field(l, 1), i++) { + arrays[i] = Field(l, 0); + offsets[i] = 0; + lengths[i] = caml_array_length(Field(l, 0)); + } + /* Do the concatenation */ + res = caml_array_gather(n, arrays, offsets, lengths); + /* Free the extra storage if needed */ + if (n > STATIC_SIZE) { + caml_stat_free(arrays); + caml_stat_free(offsets); + caml_stat_free(lengths); + } + return res; +} diff --git a/byterun/callback.h b/byterun/callback.h index 550053add3..829f6b8841 100644 --- a/byterun/callback.h +++ b/byterun/callback.h @@ -23,6 +23,10 @@ #endif #include "mlvalues.h" +#ifdef __cplusplus +extern "C" { +#endif + CAMLextern value caml_callback (value closure, value arg); CAMLextern value caml_callback2 (value closure, value arg1, value arg2); CAMLextern value caml_callback3 (value closure, value arg1, value arg2, @@ -46,4 +50,8 @@ CAMLextern void caml_startup (char ** argv); CAMLextern int caml_callback_depth; +#ifdef __cplusplus +} +#endif + #endif diff --git a/byterun/custom.h b/byterun/custom.h index f71fb4fe16..c6abad8ef0 100644 --- a/byterun/custom.h +++ b/byterun/custom.h @@ -43,6 +43,11 @@ struct custom_operations { #define Custom_ops_val(v) (*((struct custom_operations **) (v))) +#ifdef __cplusplus +extern "C" { +#endif + + CAMLextern value caml_alloc_custom(struct custom_operations * ops, uintnat size, /*size in bytes*/ mlsize_t mem, /*resources consumed*/ @@ -61,4 +66,8 @@ extern struct custom_operations * extern void caml_init_custom_operations(void); /* </private> */ +#ifdef __cplusplus +} +#endif + #endif /* CAML_CUSTOM_H */ diff --git a/byterun/fail.h b/byterun/fail.h index 91b2bcb7b0..ee05eb7f8a 100644 --- a/byterun/fail.h +++ b/byterun/fail.h @@ -58,6 +58,10 @@ int caml_is_special_exception(value exn); /* </private> */ +#ifdef __cplusplus +extern "C" { +#endif + CAMLextern void caml_raise (value bucket) Noreturn; CAMLextern void caml_raise_constant (value tag) Noreturn; CAMLextern void caml_raise_with_arg (value tag, value arg) Noreturn; @@ -75,4 +79,8 @@ CAMLextern void caml_init_exceptions (void); CAMLextern void caml_array_bound_error (void) Noreturn; CAMLextern void caml_raise_sys_blocked_io (void) Noreturn; +#ifdef __cplusplus +} +#endif + #endif /* CAML_FAIL_H */ diff --git a/byterun/floats.c b/byterun/floats.c index 51cfb23f18..f708d70f70 100644 --- a/byterun/floats.c +++ b/byterun/floats.c @@ -28,6 +28,12 @@ #include "reverse.h" #include "stacks.h" +#ifdef _MSC_VER +#include <float.h> +#define isnan _isnan +#define isfinite _finite +#endif + #ifdef ARCH_ALIGN_DOUBLE CAMLexport double caml_Double_val(value val) @@ -77,7 +83,11 @@ CAMLprim value caml_format_float(value fmt, value arg) char * p; char * dest; value res; + double d = Double_val(arg); +#ifdef HAS_BROKEN_PRINTF + if (isfinite(d)) { +#endif prec = MAX_DIGITS; for (p = String_val(fmt); *p != 0; p++) { if (*p >= '0' && *p <= '9') { @@ -98,11 +108,30 @@ CAMLprim value caml_format_float(value fmt, value arg) } else { dest = caml_stat_alloc(prec); } - sprintf(dest, String_val(fmt), Double_val(arg)); + sprintf(dest, String_val(fmt), d); res = caml_copy_string(dest); if (dest != format_buffer) { caml_stat_free(dest); } +#ifdef HAS_BROKEN_PRINTF + } else { + if (isnan(d)) + { + res = caml_copy_string("nan"); + } + else + { + if (d > 0) + { + res = caml_copy_string("inf"); + } + else + { + res = caml_copy_string("-inf"); + } + } + } +#endif return res; } diff --git a/byterun/intern.c b/byterun/intern.c index 9fa403ad66..35d293b603 100644 --- a/byterun/intern.c +++ b/byterun/intern.c @@ -19,6 +19,7 @@ #include <string.h> #include "alloc.h" +#include "callback.h" #include "custom.h" #include "fail.h" #include "gc.h" @@ -63,6 +64,10 @@ static value intern_block; /* Point to the heap block allocated as destination block. Meaningful only if intern_extra_block is NULL. */ +static value * camlinternaloo_last_id = NULL; +/* Pointer to a reference holding the last object id. + -1 means not available (CamlinternalOO not loaded). */ + #define Sign_extend_shift ((sizeof(intnat) - 1) * 8) #define Sign_extend(x) (((intnat)(x) << Sign_extend_shift) >> Sign_extend_shift) @@ -139,6 +144,22 @@ static void intern_rec(value *dest) dest = (value *) (intern_dest + 1); *intern_dest = Make_header(size, tag, intern_color); intern_dest += 1 + size; + /* For objects, we need to freshen the oid */ + if (tag == Object_tag && camlinternaloo_last_id != (value*)-1) { + intern_rec(dest++); + intern_rec(dest++); + if (camlinternaloo_last_id == NULL) + camlinternaloo_last_id = caml_named_value("CamlinternalOO.last_id"); + if (camlinternaloo_last_id == NULL) + camlinternaloo_last_id = (value*)-1; + else { + value id = Field(*camlinternaloo_last_id,0); + Field(dest,-1) = id; + Field(*camlinternaloo_last_id,0) = id + 2; + } + size -= 2; + if (size == 0) return; + } for(/*nothing*/; size > 1; size--, dest++) intern_rec(dest); goto tailcall; @@ -328,6 +349,8 @@ static void intern_alloc(mlsize_t whsize, mlsize_t num_objects) { mlsize_t wosize; + if (camlinternaloo_last_id == (value*)-1) + camlinternaloo_last_id = NULL; /* Reset ignore flag */ if (whsize == 0) { intern_obj_table = NULL; intern_extra_block = NULL; diff --git a/byterun/intext.h b/byterun/intext.h index 05fc614419..b771a34ad8 100644 --- a/byterun/intext.h +++ b/byterun/intext.h @@ -81,6 +81,10 @@ void caml_output_val (struct channel * chan, value v, value flags); /* </private> */ +#ifdef __cplusplus +extern "C" { +#endif + CAMLextern void caml_output_value_to_malloc(value v, value flags, /*out*/ char ** buf, /*out*/ intnat * len); @@ -159,4 +163,8 @@ extern char * caml_code_area_start, * caml_code_area_end; /* </private> */ +#ifdef __cplusplus +} +#endif + #endif /* CAML_INTEXT_H */ diff --git a/byterun/memory.c b/byterun/memory.c index 2a98ada34a..b0801f130b 100644 --- a/byterun/memory.c +++ b/byterun/memory.c @@ -353,7 +353,7 @@ void caml_shrink_heap (char *chunk) { char **cp; - /* Never deallocate the first block, because caml_heap_start is both the + /* Never deallocate the first chunk, because caml_heap_start is both the first block and the base address for page numbers, and we don't want to shift the page table, it's too messy (see above). It will never happen anyway, because of the way compaction works. diff --git a/byterun/memory.h b/byterun/memory.h index 0c659b84e8..cbeeb756fa 100644 --- a/byterun/memory.h +++ b/byterun/memory.h @@ -30,6 +30,11 @@ #include "misc.h" #include "mlvalues.h" +#ifdef __cplusplus +extern "C" { +#endif + + CAMLextern value caml_alloc_shr (mlsize_t, tag_t); CAMLextern void caml_adjust_gc_speed (mlsize_t, mlsize_t); CAMLextern void caml_alloc_dependent_memory (mlsize_t); @@ -456,4 +461,8 @@ CAMLextern void caml_remove_generational_global_root (value *); CAMLextern void caml_modify_generational_global_root(value *r, value newval); +#ifdef __cplusplus +} +#endif + #endif /* CAML_MEMORY_H */ diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h index 201b86bda0..d560d1b3ae 100644 --- a/byterun/mlvalues.h +++ b/byterun/mlvalues.h @@ -22,6 +22,10 @@ #include "config.h" #include "misc.h" +#ifdef __cplusplus +extern "C" { +#endif + /* Definitions word: Four bytes on 32 and 16 bit architectures, @@ -294,5 +298,9 @@ CAMLextern header_t caml_atom_table[]; extern value caml_global_data; +#ifdef __cplusplus +} +#endif + #endif /* CAML_MLVALUES_H */ diff --git a/byterun/obj.c b/byterun/obj.c index 72464b315f..f095df5ae6 100644 --- a/byterun/obj.c +++ b/byterun/obj.c @@ -191,7 +191,7 @@ CAMLprim value caml_lazy_make_forward (value v) CAMLlocal1 (res); res = caml_alloc_small (1, Forward_tag); - Modify (&Field (res, 0), v); + Field (res, 0) = v; CAMLreturn (res); } diff --git a/byterun/parsing.c b/byterun/parsing.c index aeba38d622..3d5ea83323 100644 --- a/byterun/parsing.c +++ b/byterun/parsing.c @@ -125,7 +125,7 @@ static void print_token(struct parser_tables *tables, int state, value tok) state, token_name(tables->names_block, Tag_val(tok))); v = Field(tok, 0); if (Is_long(v)) - fprintf(stderr, "%ld", Long_val(v)); + fprintf(stderr, "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v)); else if (Tag_val(v) == String_tag) fprintf(stderr, "%s", String_val(v)); else if (Tag_val(v) == Double_tag) diff --git a/byterun/printexc.c b/byterun/printexc.c index f50853d90a..e891d9c677 100644 --- a/byterun/printexc.c +++ b/byterun/printexc.c @@ -73,7 +73,7 @@ CAMLexport char * caml_format_exception(value exn) if (i > start) add_string(&buf, ", "); v = Field(bucket, i); if (Is_long(v)) { - sprintf(intbuf, "%ld", Long_val(v)); + sprintf(intbuf, "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v)); add_string(&buf, intbuf); } else if (Tag_val(v) == String_tag) { add_char(&buf, '"'); diff --git a/byterun/printexc.h b/byterun/printexc.h index 5b0549b23f..4624086cb3 100644 --- a/byterun/printexc.h +++ b/byterun/printexc.h @@ -20,8 +20,16 @@ #include "misc.h" #include "mlvalues.h" +#ifdef __cplusplus +extern "C" { +#endif + + CAMLextern char * caml_format_exception (value); void caml_fatal_uncaught_exception (value) Noreturn; +#ifdef __cplusplus +} +#endif #endif /* CAML_PRINTEXC_H */ diff --git a/byterun/signals.h b/byterun/signals.h index f771a799e8..fb03b30dd5 100644 --- a/byterun/signals.h +++ b/byterun/signals.h @@ -22,6 +22,10 @@ #include "misc.h" #include "mlvalues.h" +#ifdef __cplusplus +extern "C" { +#endif + /* <private> */ CAMLextern intnat volatile caml_signals_are_pending; CAMLextern intnat volatile caml_pending_signals[]; @@ -48,4 +52,8 @@ CAMLextern int (*caml_try_leave_blocking_section_hook)(void); CAMLextern void (* volatile caml_async_action_hook)(void); /* </private> */ +#ifdef __cplusplus +} +#endif + #endif /* CAML_SIGNALS_H */ |