diff options
Diffstat (limited to 'test/monniaux/ocaml/byterun/intern.c')
| -rw-r--r-- | test/monniaux/ocaml/byterun/intern.c | 1048 |
1 files changed, 1048 insertions, 0 deletions
diff --git a/test/monniaux/ocaml/byterun/intern.c b/test/monniaux/ocaml/byterun/intern.c new file mode 100644 index 00000000..565ed10d --- /dev/null +++ b/test/monniaux/ocaml/byterun/intern.c @@ -0,0 +1,1048 @@ +/**************************************************************************/ +/* */ +/* 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 + +/* Structured input, compact format */ + +/* The interface of this file is "caml/intext.h" */ + +#include <string.h> +#include <stdio.h> +#include "caml/alloc.h" +#include "caml/callback.h" +#include "caml/config.h" +#include "caml/custom.h" +#include "caml/fail.h" +#include "caml/gc.h" +#include "caml/intext.h" +#include "caml/io.h" +#include "caml/md5.h" +#include "caml/memory.h" +#include "caml/mlvalues.h" +#include "caml/misc.h" +#include "caml/reverse.h" + +static unsigned char * intern_src; +/* Reading pointer in block holding input data. */ + +static unsigned char * intern_input = NULL; +/* Pointer to beginning of block holding input data, + if non-NULL this pointer will be freed by the cleanup function. */ + +static header_t * intern_dest; +/* Writing pointer in destination block */ + +static char * intern_extra_block = NULL; +/* If non-NULL, point to new heap chunk allocated with caml_alloc_for_heap. */ + +static asize_t obj_counter; +/* Count how many objects seen so far */ + +static value * intern_obj_table = NULL; +/* The pointers to objects already seen */ + +static unsigned int intern_color; +/* Color to assign to newly created headers */ + +static header_t intern_header; +/* Original header of the destination block. + Meaningful only if intern_extra_block is NULL. */ + +static value intern_block = 0; +/* Point to the heap block allocated as destination block. + Meaningful only if intern_extra_block is NULL. */ + +static char * intern_resolve_code_pointer(unsigned char digest[16], + asize_t offset); + +CAMLnoreturn_start +static void intern_bad_code_pointer(unsigned char digest[16]) +CAMLnoreturn_end; + +static void intern_free_stack(void); + +static inline unsigned char read8u(void) +{ return *intern_src++; } + +static inline signed char read8s(void) +{ return *intern_src++; } + +static inline uint16_t read16u(void) +{ + uint16_t res = (intern_src[0] << 8) + intern_src[1]; + intern_src += 2; + return res; +} + +static inline int16_t read16s(void) +{ + int16_t res = (intern_src[0] << 8) + intern_src[1]; + intern_src += 2; + return res; +} + +static inline uint32_t read32u(void) +{ + uint32_t res = + ((uint32_t)(intern_src[0]) << 24) + (intern_src[1] << 16) + + (intern_src[2] << 8) + intern_src[3]; + intern_src += 4; + return res; +} + +static inline int32_t read32s(void) +{ + int32_t res = + ((uint32_t)(intern_src[0]) << 24) + (intern_src[1] << 16) + + (intern_src[2] << 8) + intern_src[3]; + intern_src += 4; + return res; +} + +#ifdef ARCH_SIXTYFOUR +static uintnat read64u(void) +{ + uintnat res = + ((uintnat) (intern_src[0]) << 56) + + ((uintnat) (intern_src[1]) << 48) + + ((uintnat) (intern_src[2]) << 40) + + ((uintnat) (intern_src[3]) << 32) + + ((uintnat) (intern_src[4]) << 24) + + ((uintnat) (intern_src[5]) << 16) + + ((uintnat) (intern_src[6]) << 8) + + (uintnat) (intern_src[7]); + intern_src += 8; + return res; +} +#endif + +static inline void readblock(void * dest, intnat len) +{ + memcpy(dest, intern_src, len); + intern_src += len; +} + +static void intern_init(void * src, void * input) +{ + /* This is asserted at the beginning of demarshaling primitives. + If it fails, it probably means that an exception was raised + without calling intern_cleanup() during the previous demarshaling. */ + CAMLassert (intern_input == NULL && intern_obj_table == NULL \ + && intern_extra_block == NULL && intern_block == 0); + intern_src = src; + intern_input = input; +} + +static void intern_cleanup(void) +{ + if (intern_input != NULL) { + caml_stat_free(intern_input); + intern_input = NULL; + } + if (intern_obj_table != NULL) { + caml_stat_free(intern_obj_table); + intern_obj_table = NULL; + } + if (intern_extra_block != NULL) { + /* free newly allocated heap chunk */ + caml_free_for_heap(intern_extra_block); + intern_extra_block = NULL; + } else if (intern_block != 0) { + /* restore original header for heap block, otherwise GC is confused */ + Hd_val(intern_block) = intern_header; + intern_block = 0; + } + /* free the recursion stack */ + intern_free_stack(); +} + +static void readfloat(double * dest, unsigned int code) +{ + if (sizeof(double) != 8) { + intern_cleanup(); + caml_invalid_argument("input_value: non-standard floats"); + } + readblock((char *) dest, 8); + /* Fix up endianness, if needed */ +#if ARCH_FLOAT_ENDIANNESS == 0x76543210 + /* Host is big-endian; fix up if data read is little-endian */ + if (code != CODE_DOUBLE_BIG) Reverse_64(dest, dest); +#elif ARCH_FLOAT_ENDIANNESS == 0x01234567 + /* Host is little-endian; fix up if data read is big-endian */ + if (code != CODE_DOUBLE_LITTLE) Reverse_64(dest, dest); +#else + /* Host is neither big nor little; permute as appropriate */ + if (code == CODE_DOUBLE_LITTLE) + Permute_64(dest, ARCH_FLOAT_ENDIANNESS, dest, 0x01234567) + else + Permute_64(dest, ARCH_FLOAT_ENDIANNESS, dest, 0x76543210); +#endif +} + +/* [len] is a number of floats */ +static void readfloats(double * dest, mlsize_t len, unsigned int code) +{ + mlsize_t i; + if (sizeof(double) != 8) { + intern_cleanup(); + caml_invalid_argument("input_value: non-standard floats"); + } + readblock((char *) dest, len * 8); + /* Fix up endianness, if needed */ +#if ARCH_FLOAT_ENDIANNESS == 0x76543210 + /* Host is big-endian; fix up if data read is little-endian */ + if (code != CODE_DOUBLE_ARRAY8_BIG && + code != CODE_DOUBLE_ARRAY32_BIG) { + for (i = 0; i < len; i++) Reverse_64(dest + i, dest + i); + } +#elif ARCH_FLOAT_ENDIANNESS == 0x01234567 + /* Host is little-endian; fix up if data read is big-endian */ + if (code != CODE_DOUBLE_ARRAY8_LITTLE && + code != CODE_DOUBLE_ARRAY32_LITTLE) { + for (i = 0; i < len; i++) Reverse_64(dest + i, dest + i); + } +#else + /* Host is neither big nor little; permute as appropriate */ + if (code == CODE_DOUBLE_ARRAY8_LITTLE || + code == CODE_DOUBLE_ARRAY32_LITTLE) { + for (i = 0; i < len; i++) + Permute_64(dest + i, ARCH_FLOAT_ENDIANNESS, dest + i, 0x01234567); + } else { + for (i = 0; i < len; i++) + Permute_64(dest + i, ARCH_FLOAT_ENDIANNESS, dest + i, 0x76543210); + } +#endif +} + +/* Item on the stack with defined operation */ +struct intern_item { + value * dest; + intnat arg; + enum { + OReadItems, /* read arg items and store them in dest[0], dest[1], ... */ + OFreshOID, /* generate a fresh OID and store it in *dest */ + OShift /* offset *dest by arg */ + } op; +}; + +/* FIXME: This is duplicated in two other places, with the only difference of + the type of elements stored in the stack. Possible solution in C would + be to instantiate stack these function via. C preprocessor macro. + */ + +#define INTERN_STACK_INIT_SIZE 256 +#define INTERN_STACK_MAX_SIZE (1024*1024*100) + +static struct intern_item intern_stack_init[INTERN_STACK_INIT_SIZE]; + +static struct intern_item * intern_stack = intern_stack_init; +static struct intern_item * intern_stack_limit = intern_stack_init + + INTERN_STACK_INIT_SIZE; + +/* Free the recursion stack if needed */ +static void intern_free_stack(void) +{ + if (intern_stack != intern_stack_init) { + caml_stat_free(intern_stack); + /* Reinitialize the globals for next time around */ + intern_stack = intern_stack_init; + intern_stack_limit = intern_stack + INTERN_STACK_INIT_SIZE; + } +} + +/* Same, then raise Out_of_memory */ +static void intern_stack_overflow(void) +{ + caml_gc_message (0x04, "Stack overflow in un-marshaling value\n"); + intern_free_stack(); + caml_raise_out_of_memory(); +} + +static struct intern_item * intern_resize_stack(struct intern_item * sp) +{ + asize_t newsize = 2 * (intern_stack_limit - intern_stack); + asize_t sp_offset = sp - intern_stack; + struct intern_item * newstack; + + if (newsize >= INTERN_STACK_MAX_SIZE) intern_stack_overflow(); + if (intern_stack == intern_stack_init) { + newstack = caml_stat_alloc_noexc(sizeof(struct intern_item) * newsize); + if (newstack == NULL) intern_stack_overflow(); + memcpy(newstack, intern_stack_init, + sizeof(struct intern_item) * INTERN_STACK_INIT_SIZE); + } else { + newstack = caml_stat_resize_noexc(intern_stack, + sizeof(struct intern_item) * newsize); + if (newstack == NULL) intern_stack_overflow(); + } + intern_stack = newstack; + intern_stack_limit = newstack + newsize; + return newstack + sp_offset; +} + +/* Convenience macros for requesting operation on the stack */ +#define PushItem() \ + do { \ + sp++; \ + if (sp >= intern_stack_limit) sp = intern_resize_stack(sp); \ + } while(0) + +#define ReadItems(_dest,_n) \ + do { \ + if (_n > 0) { \ + PushItem(); \ + sp->op = OReadItems; \ + sp->dest = _dest; \ + sp->arg = _n; \ + } \ + } while(0) + +static void intern_rec(value *dest) +{ + unsigned int code; + tag_t tag; + mlsize_t size, len, ofs_ind; + value v; + asize_t ofs; + header_t header; + unsigned char digest[16]; + struct custom_operations * ops; + char * codeptr; + struct intern_item * sp; + + sp = intern_stack; + + /* Initially let's try to read the first object from the stream */ + ReadItems(dest, 1); + + /* The un-marshaler loop, the recursion is unrolled */ + while(sp != intern_stack) { + + /* Interpret next item on the stack */ + dest = sp->dest; + switch (sp->op) { + case OFreshOID: + /* Refresh the object ID */ + /* but do not do it for predefined exception slots */ + if (Long_val(Field((value)dest, 1)) >= 0) + caml_set_oo_id((value)dest); + /* Pop item and iterate */ + sp--; + break; + case OShift: + /* Shift value by an offset */ + *dest += sp->arg; + /* Pop item and iterate */ + sp--; + break; + case OReadItems: + /* Pop item */ + sp->dest++; + if (--(sp->arg) == 0) sp--; + /* Read a value and set v to this value */ + code = read8u(); + if (code >= PREFIX_SMALL_INT) { + if (code >= PREFIX_SMALL_BLOCK) { + /* Small block */ + tag = code & 0xF; + size = (code >> 4) & 0x7; + read_block: + if (size == 0) { + v = Atom(tag); + } else { + v = Val_hp(intern_dest); + if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; + *intern_dest = Make_header_allocated_here(size, tag, intern_color); + intern_dest += 1 + size; + /* For objects, we need to freshen the oid */ + if (tag == Object_tag) { + CAMLassert(size >= 2); + /* Request to read rest of the elements of the block */ + ReadItems(&Field(v, 2), size - 2); + /* Request freshing OID */ + PushItem(); + sp->op = OFreshOID; + sp->dest = (value*) v; + sp->arg = 1; + /* Finally read first two block elements: method table and old OID */ + ReadItems(&Field(v, 0), 2); + } else + /* If it's not an object then read the contents of the block */ + ReadItems(&Field(v, 0), size); + } + } else { + /* Small integer */ + v = Val_int(code & 0x3F); + } + } else { + if (code >= PREFIX_SMALL_STRING) { + /* Small string */ + len = (code & 0x1F); + read_string: + size = (len + sizeof(value)) / sizeof(value); + v = Val_hp(intern_dest); + if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; + *intern_dest = Make_header_allocated_here(size, String_tag, intern_color); + intern_dest += 1 + size; + Field(v, size - 1) = 0; + ofs_ind = Bsize_wsize(size) - 1; + Byte(v, ofs_ind) = ofs_ind - len; + readblock((char *)String_val(v), len); + } else { + switch(code) { + case CODE_INT8: + v = Val_long(read8s()); + break; + case CODE_INT16: + v = Val_long(read16s()); + break; + case CODE_INT32: + v = Val_long(read32s()); + break; + case CODE_INT64: +#ifdef ARCH_SIXTYFOUR + v = Val_long((intnat) (read64u())); + break; +#else + intern_cleanup(); + caml_failwith("input_value: integer too large"); + break; +#endif + case CODE_SHARED8: + ofs = read8u(); + read_shared: + CAMLassert (ofs > 0); + CAMLassert (ofs <= obj_counter); + CAMLassert (intern_obj_table != NULL); + v = intern_obj_table[obj_counter - ofs]; + break; + case CODE_SHARED16: + ofs = read16u(); + goto read_shared; + case CODE_SHARED32: + ofs = read32u(); + goto read_shared; +#ifdef ARCH_SIXTYFOUR + case CODE_SHARED64: + ofs = read64u(); + goto read_shared; +#endif + case CODE_BLOCK32: + header = (header_t) read32u(); + tag = Tag_hd(header); + size = Wosize_hd(header); + goto read_block; +#ifdef ARCH_SIXTYFOUR + case CODE_BLOCK64: + header = (header_t) read64u(); + tag = Tag_hd(header); + size = Wosize_hd(header); + goto read_block; +#endif + case CODE_STRING8: + len = read8u(); + goto read_string; + case CODE_STRING32: + len = read32u(); + goto read_string; +#ifdef ARCH_SIXTYFOUR + case CODE_STRING64: + len = read64u(); + goto read_string; +#endif + case CODE_DOUBLE_LITTLE: + case CODE_DOUBLE_BIG: + v = Val_hp(intern_dest); + if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; + *intern_dest = Make_header_allocated_here(Double_wosize, Double_tag, + intern_color); + intern_dest += 1 + Double_wosize; + readfloat((double *) v, code); + break; + case CODE_DOUBLE_ARRAY8_LITTLE: + case CODE_DOUBLE_ARRAY8_BIG: + len = read8u(); + read_double_array: + size = len * Double_wosize; + v = Val_hp(intern_dest); + if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; + *intern_dest = Make_header_allocated_here(size, Double_array_tag, + intern_color); + intern_dest += 1 + size; + readfloats((double *) v, len, code); + break; + case CODE_DOUBLE_ARRAY32_LITTLE: + case CODE_DOUBLE_ARRAY32_BIG: + len = read32u(); + goto read_double_array; +#ifdef ARCH_SIXTYFOUR + case CODE_DOUBLE_ARRAY64_LITTLE: + case CODE_DOUBLE_ARRAY64_BIG: + len = read64u(); + goto read_double_array; +#endif + case CODE_CODEPOINTER: + ofs = read32u(); + readblock(digest, 16); + codeptr = intern_resolve_code_pointer(digest, ofs); + if (codeptr != NULL) { + v = (value) codeptr; + } else { + value * function_placeholder = + caml_named_value ("Debugger.function_placeholder"); + if (function_placeholder != NULL) { + v = *function_placeholder; + } else { + intern_cleanup(); + intern_bad_code_pointer(digest); + } + } + break; + case CODE_INFIXPOINTER: + ofs = read32u(); + /* Read a value to *dest, then offset *dest by ofs */ + PushItem(); + sp->dest = dest; + sp->op = OShift; + sp->arg = ofs; + ReadItems(dest, 1); + continue; /* with next iteration of main loop, skipping *dest = v */ + case CODE_CUSTOM: + ops = caml_find_custom_operations((char *) intern_src); + if (ops == NULL) { + intern_cleanup(); + caml_failwith("input_value: unknown custom block identifier"); + } + while (*intern_src++ != 0) /*nothing*/; /*skip identifier*/ + size = ops->deserialize((void *) (intern_dest + 2)); + size = 1 + (size + sizeof(value) - 1) / sizeof(value); + v = Val_hp(intern_dest); + if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; + *intern_dest = Make_header_allocated_here(size, Custom_tag, + intern_color); + Custom_ops_val(v) = ops; + + if (ops->finalize != NULL && Is_young(v)) { + /* Remember that the block has a finalizer. */ + add_to_custom_table (&caml_custom_table, v, 0, 1); + } + + intern_dest += 1 + size; + break; + default: + intern_cleanup(); + caml_failwith("input_value: ill-formed message"); + } + } + } + /* end of case OReadItems */ + *dest = v; + break; + default: + CAMLassert(0); + } + } + /* We are done. Cleanup the stack and leave the function */ + intern_free_stack(); +} + +static void intern_alloc(mlsize_t whsize, mlsize_t num_objects, + int outside_heap) +{ + mlsize_t wosize; + + if (whsize == 0) { + CAMLassert (intern_extra_block == NULL && intern_block == 0 + && intern_obj_table == NULL); + return; + } + wosize = Wosize_whsize(whsize); + if (outside_heap || wosize > Max_wosize) { + /* Round desired size up to next page */ + asize_t request = + ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log; + intern_extra_block = caml_alloc_for_heap(request); + if (intern_extra_block == NULL) { + intern_cleanup(); + caml_raise_out_of_memory(); + } + intern_color = + outside_heap ? Caml_black : caml_allocation_color(intern_extra_block); + intern_dest = (header_t *) intern_extra_block; + CAMLassert (intern_block == 0); + } else { + /* this is a specialised version of caml_alloc from alloc.c */ + if (wosize <= Max_young_wosize){ + if (wosize == 0){ + intern_block = Atom (String_tag); + } else { + intern_block = caml_alloc_small (wosize, String_tag); + } + }else{ + intern_block = caml_alloc_shr_no_raise (wosize, String_tag); + /* do not do the urgent_gc check here because it might darken + intern_block into gray and break the intern_color assertion below */ + if (intern_block == 0) { + intern_cleanup(); + caml_raise_out_of_memory(); + } + } + intern_header = Hd_val(intern_block); + intern_color = Color_hd(intern_header); + CAMLassert (intern_color == Caml_white || intern_color == Caml_black); + intern_dest = (header_t *) Hp_val(intern_block); + CAMLassert (intern_extra_block == NULL); + } + obj_counter = 0; + if (num_objects > 0) { + intern_obj_table = (value *) caml_stat_alloc_noexc(num_objects * sizeof(value)); + if (intern_obj_table == NULL) { + intern_cleanup(); + caml_raise_out_of_memory(); + } + } else + CAMLassert(intern_obj_table == NULL); +} + +static void intern_add_to_heap(mlsize_t whsize) +{ + /* Add new heap chunk to heap if needed */ + if (intern_extra_block != NULL) { + /* If heap chunk not filled totally, build free block at end */ + asize_t request = Chunk_size (intern_extra_block); + header_t * end_extra_block = + (header_t *) intern_extra_block + Wsize_bsize(request); + CAMLassert(intern_block == 0); + CAMLassert(intern_dest <= end_extra_block); + if (intern_dest < end_extra_block){ + caml_make_free_blocks ((value *) intern_dest, + end_extra_block - intern_dest, 0, Caml_white); + } + caml_allocated_words += + Wsize_bsize ((char *) intern_dest - intern_extra_block); + caml_add_to_heap(intern_extra_block); + intern_extra_block = NULL; // To prevent intern_cleanup freeing it + } else { + intern_block = 0; // To prevent intern_cleanup rewriting its header + } +} + +/* Parsing the header */ + +struct marshal_header { + uint32_t magic; + int header_len; + uintnat data_len; + uintnat num_objects; + uintnat whsize; +}; + +static void caml_parse_header(char * fun_name, + /*out*/ struct marshal_header * h) +{ + char errmsg[100]; + + h->magic = read32u(); + switch(h->magic) { + case Intext_magic_number_small: + h->header_len = 20; + h->data_len = read32u(); + h->num_objects = read32u(); +#ifdef ARCH_SIXTYFOUR + read32u(); + h->whsize = read32u(); +#else + h->whsize = read32u(); + read32u(); +#endif + break; + case Intext_magic_number_big: +#ifdef ARCH_SIXTYFOUR + h->header_len = 32; + read32u(); + h->data_len = read64u(); + h->num_objects = read64u(); + h->whsize = read64u(); +#else + errmsg[sizeof(errmsg) - 1] = 0; + snprintf(errmsg, sizeof(errmsg) - 1, + "%s: object too large to be read back on a 32-bit platform", + fun_name); + caml_failwith(errmsg); +#endif + break; + default: + errmsg[sizeof(errmsg) - 1] = 0; + snprintf(errmsg, sizeof(errmsg) - 1, + "%s: bad object", + fun_name); + caml_failwith(errmsg); + } +} + +/* Reading from a channel */ + +static value caml_input_val_core(struct channel *chan, int outside_heap) +{ + intnat r; + char header[32]; + struct marshal_header h; + char * block; + value res; + + if (! caml_channel_binary_mode(chan)) + caml_failwith("input_value: not a binary channel"); + /* Read and parse the header */ + r = caml_really_getblock(chan, header, 20); + if (r == 0) + caml_raise_end_of_file(); + else if (r < 20) + caml_failwith("input_value: truncated object"); + intern_src = (unsigned char *) header; + if (read32u() == Intext_magic_number_big) { + /* Finish reading the header */ + if (caml_really_getblock(chan, header + 20, 32 - 20) < 32 - 20) + caml_failwith("input_value: truncated object"); + } + intern_src = (unsigned char *) header; + caml_parse_header("input_value", &h); + /* Read block from channel */ + block = caml_stat_alloc(h.data_len); + /* During [caml_really_getblock], concurrent [caml_input_val] operations + can take place (via signal handlers or context switching in systhreads), + and [intern_input] may change. So, wait until [caml_really_getblock] + is over before using [intern_input] and the other global vars. */ + if (caml_really_getblock(chan, block, h.data_len) < h.data_len) { + caml_stat_free(block); + caml_failwith("input_value: truncated object"); + } + /* Initialize global state */ + intern_init(block, block); + intern_alloc(h.whsize, h.num_objects, outside_heap); + /* Fill it in */ + intern_rec(&res); + if (!outside_heap) { + intern_add_to_heap(h.whsize); + } else { + caml_disown_for_heap(intern_extra_block); + intern_extra_block = NULL; + intern_block = 0; + } + /* Free everything */ + intern_cleanup(); + return caml_check_urgent_gc(res); +} + +value caml_input_val(struct channel* chan) +{ + return caml_input_val_core(chan, 0); +} + +CAMLprim value caml_input_value(value vchan) +{ + CAMLparam1 (vchan); + struct channel * chan = Channel(vchan); + CAMLlocal1 (res); + + Lock(chan); + res = caml_input_val(chan); + Unlock(chan); + CAMLreturn (res); +} + +/* Reading from memory-resident blocks */ + +CAMLprim value caml_input_value_to_outside_heap(value vchan) +{ + CAMLparam1 (vchan); + struct channel * chan = Channel(vchan); + CAMLlocal1 (res); + + Lock(chan); + res = caml_input_val_core(chan, 1); + Unlock(chan); + CAMLreturn (res); +} + +CAMLexport value caml_input_val_from_bytes(value str, intnat ofs) +{ + CAMLparam1 (str); + CAMLlocal1 (obj); + struct marshal_header h; + + /* Initialize global state */ + intern_init(&Byte_u(str, ofs), NULL); + caml_parse_header("input_val_from_string", &h); + if (ofs + h.header_len + h.data_len > caml_string_length(str)) + caml_failwith("input_val_from_string: bad length"); + /* Allocate result */ + intern_alloc(h.whsize, h.num_objects, 0); + intern_src = &Byte_u(str, ofs + h.header_len); /* If a GC occurred */ + /* Fill it in */ + intern_rec(&obj); + intern_add_to_heap(h.whsize); + /* Free everything */ + intern_cleanup(); + CAMLreturn (caml_check_urgent_gc(obj)); +} + +CAMLprim value caml_input_value_from_string(value str, value ofs) +{ + return caml_input_val_from_bytes(str, Long_val(ofs)); +} + +CAMLprim value caml_input_value_from_bytes(value str, value ofs) +{ + return caml_input_val_from_bytes(str, Long_val(ofs)); +} + +static value input_val_from_block(struct marshal_header * h) +{ + value obj; + /* Allocate result */ + intern_alloc(h->whsize, h->num_objects, 0); + /* Fill it in */ + intern_rec(&obj); + intern_add_to_heap(h->whsize); + /* Free internal data structures */ + intern_cleanup(); + return caml_check_urgent_gc(obj); +} + +CAMLexport value caml_input_value_from_malloc(char * data, intnat ofs) +{ + struct marshal_header h; + + intern_init(data + ofs, data); + + caml_parse_header("input_value_from_malloc", &h); + + return input_val_from_block(&h); +} + +/* [len] is a number of bytes */ +CAMLexport value caml_input_value_from_block(char * data, intnat len) +{ + struct marshal_header h; + + /* Initialize global state */ + intern_init(data, NULL); + caml_parse_header("input_value_from_block", &h); + if (h.header_len + h.data_len > len) + caml_failwith("input_val_from_block: bad length"); + return input_val_from_block(&h); +} + +/* [ofs] is a [value] that represents a number of bytes + result is a [value] that represents a number of bytes + To handle both the small and the big format, + we assume 20 bytes are available at [buff + ofs], + and we return the data size + the length of the part of the header + that remains to be read. */ + +CAMLprim value caml_marshal_data_size(value buff, value ofs) +{ + uint32_t magic; + int header_len; + uintnat data_len; + + intern_src = &Byte_u(buff, Long_val(ofs)); + magic = read32u(); + switch(magic) { + case Intext_magic_number_small: + header_len = 20; + data_len = read32u(); + break; + case Intext_magic_number_big: +#ifdef ARCH_SIXTYFOUR + header_len = 32; + read32u(); + data_len = read64u(); +#else + caml_failwith("Marshal.data_size: " + "object too large to be read back on a 32-bit platform"); +#endif + break; + default: + caml_failwith("Marshal.data_size: bad object"); + } + return Val_long((header_len - 20) + data_len); +} + +/* Resolution of code pointers */ + +static char * intern_resolve_code_pointer(unsigned char digest[16], + asize_t offset) +{ + int i; + for (i = caml_code_fragments_table.size - 1; i >= 0; i--) { + struct code_fragment * cf = caml_code_fragments_table.contents[i]; + if (! cf->digest_computed) { + caml_md5_block(cf->digest, cf->code_start, cf->code_end - cf->code_start); + cf->digest_computed = 1; + } + if (memcmp(digest, cf->digest, 16) == 0) { + if (cf->code_start + offset < cf->code_end) + return cf->code_start + offset; + else + return NULL; + } + } + return NULL; +} + +static void intern_bad_code_pointer(unsigned char digest[16]) +{ + char msg[256]; + snprintf(msg, sizeof(msg), + "input_value: unknown code module " + "%02X%02X%02X%02X%02X%02X%02X%02X" + "%02X%02X%02X%02X%02X%02X%02X%02X", + digest[0], digest[1], digest[2], digest[3], + digest[4], digest[5], digest[6], digest[7], + digest[8], digest[9], digest[10], digest[11], + digest[12], digest[13], digest[14], digest[15]); + caml_failwith(msg); +} + +/* Functions for writing user-defined marshallers */ + +CAMLexport int caml_deserialize_uint_1(void) +{ + return read8u(); +} + +CAMLexport int caml_deserialize_sint_1(void) +{ + return read8s(); +} + +CAMLexport int caml_deserialize_uint_2(void) +{ + return read16u(); +} + +CAMLexport int caml_deserialize_sint_2(void) +{ + return read16s(); +} + +CAMLexport uint32_t caml_deserialize_uint_4(void) +{ + return read32u(); +} + +CAMLexport int32_t caml_deserialize_sint_4(void) +{ + return read32s(); +} + +CAMLexport uint64_t caml_deserialize_uint_8(void) +{ + uint64_t i; + caml_deserialize_block_8(&i, 1); + return i; +} + +CAMLexport int64_t caml_deserialize_sint_8(void) +{ + int64_t i; + caml_deserialize_block_8(&i, 1); + return i; +} + +CAMLexport float caml_deserialize_float_4(void) +{ + float f; + caml_deserialize_block_4(&f, 1); + return f; +} + +CAMLexport double caml_deserialize_float_8(void) +{ + double f; + caml_deserialize_block_float_8(&f, 1); + return f; +} + +CAMLexport void caml_deserialize_block_1(void * data, intnat len) +{ + memcpy(data, intern_src, len); + intern_src += len; +} + +CAMLexport void caml_deserialize_block_2(void * data, intnat len) +{ +#ifndef ARCH_BIG_ENDIAN + unsigned char * p, * q; + for (p = intern_src, q = data; len > 0; len--, p += 2, q += 2) + Reverse_16(q, p); + intern_src = p; +#else + memcpy(data, intern_src, len * 2); + intern_src += len * 2; +#endif +} + +CAMLexport void caml_deserialize_block_4(void * data, intnat len) +{ +#ifndef ARCH_BIG_ENDIAN + unsigned char * p, * q; + for (p = intern_src, q = data; len > 0; len--, p += 4, q += 4) + Reverse_32(q, p); + intern_src = p; +#else + memcpy(data, intern_src, len * 4); + intern_src += len * 4; +#endif +} + +CAMLexport void caml_deserialize_block_8(void * data, intnat len) +{ +#ifndef ARCH_BIG_ENDIAN + unsigned char * p, * q; + for (p = intern_src, q = data; len > 0; len--, p += 8, q += 8) + Reverse_64(q, p); + intern_src = p; +#else + memcpy(data, intern_src, len * 8); + intern_src += len * 8; +#endif +} + +CAMLexport void caml_deserialize_block_float_8(void * data, intnat len) +{ +#if ARCH_FLOAT_ENDIANNESS == 0x01234567 + memcpy(data, intern_src, len * 8); + intern_src += len * 8; +#elif ARCH_FLOAT_ENDIANNESS == 0x76543210 + unsigned char * p, * q; + for (p = intern_src, q = data; len > 0; len--, p += 8, q += 8) + Reverse_64(q, p); + intern_src = p; +#else + unsigned char * p, * q; + for (p = intern_src, q = data; len > 0; len--, p += 8, q += 8) + Permute_64(q, ARCH_FLOAT_ENDIANNESS, p, 0x01234567); + intern_src = p; +#endif +} + +CAMLexport void caml_deserialize_error(char * msg) +{ + intern_cleanup(); + caml_failwith(msg); +} |