/***********************************************************************/ /* */ /* Objective Caml */ /* */ /* 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 Library General Public License, with */ /* the special exception on linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Structured input, compact format */ /* The interface of this file is "intext.h" */ #include #include "alloc.h" #include "custom.h" #include "fail.h" #include "gc.h" #include "intext.h" #include "io.h" #include "memory.h" #include "mlvalues.h" #include "misc.h" #include "reverse.h" static unsigned char * intern_src; /* Reading pointer in block holding input data. */ static unsigned char * intern_input; /* Pointer to beginning of block holding input data. Meaningful only if intern_input_malloced = 1. */ static int intern_input_malloced; /* 1 if intern_input was allocated by caml_stat_alloc() and needs caml_stat_free() on error, 0 otherwise. */ static header_t * intern_dest; /* Writing pointer in destination block */ static char * intern_extra_block; /* 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; /* 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; /* Point to the heap block allocated as destination block. Meaningful only if intern_extra_block is NULL. */ #define Sign_extend_shift ((sizeof(long) - 1) * 8) #define Sign_extend(x) (((long)(x) << Sign_extend_shift) >> Sign_extend_shift) #define read8u() (*intern_src++) #define read8s() Sign_extend(*intern_src++) #define read16u() \ (intern_src += 2, \ (intern_src[-2] << 8) + intern_src[-1]) #define read16s() \ (intern_src += 2, \ (Sign_extend(intern_src[-2]) << 8) + intern_src[-1]) #define read32u() \ (intern_src += 4, \ (intern_src[-4] << 24) + (intern_src[-3] << 16) + \ (intern_src[-2] << 8) + intern_src[-1]) #define read32s() \ (intern_src += 4, \ (Sign_extend(intern_src[-4]) << 24) + (intern_src[-3] << 16) + \ (intern_src[-2] << 8) + intern_src[-1]) #ifdef ARCH_SIXTYFOUR static long read64s(void) { long res; int i; res = 0; for (i = 0; i < 8; i++) res = (res << 8) + intern_src[i]; intern_src += 8; return res; } #endif #define readblock(dest,len) \ (memmove((dest), intern_src, (len)), intern_src += (len)) static void intern_cleanup(void) { if (intern_input_malloced) caml_stat_free(intern_input); if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); if (intern_extra_block != NULL) { /* free newly allocated heap chunk */ caml_free_for_heap(intern_extra_block); } else if (intern_block != 0) { /* restore original header for heap block, otherwise GC is confused */ Hd_val(intern_block) = intern_header; } } static void intern_rec(value *dest) { unsigned int code; tag_t tag; mlsize_t size, len, ofs_ind; value v, clos; asize_t ofs; header_t header; char cksum[16]; struct custom_operations * ops; tailcall: 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); *dest = v; if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; dest = (value *) (intern_dest + 1); *intern_dest = Make_header(size, tag, intern_color); intern_dest += 1 + size; for(/*nothing*/; size > 1; size--, dest++) intern_rec(dest); goto tailcall; } } 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(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(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(read64s()); break; #else intern_cleanup(); caml_failwith("input_value: integer too large"); break; #endif case CODE_SHARED8: ofs = read8u(); read_shared: Assert (ofs > 0); Assert (ofs <= obj_counter); Assert (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; case CODE_BLOCK32: header = (header_t) read32u(); tag = Tag_hd(header); size = Wosize_hd(header); goto read_block; case CODE_BLOCK64: #ifdef ARCH_SIXTYFOUR header = (header_t) read64s(); tag = Tag_hd(header); size = Wosize_hd(header); goto read_block; #else intern_cleanup(); caml_failwith("input_value: data block too large"); break; #endif case CODE_STRING8: len = read8u(); goto read_string; case CODE_STRING32: len = read32u(); goto read_string; case CODE_DOUBLE_LITTLE: case CODE_DOUBLE_BIG: if (sizeof(double) != 8) { intern_cleanup(); caml_invalid_argument("input_value: non-standard floats"); } v = Val_hp(intern_dest); if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; *intern_dest = Make_header(Double_wosize, Double_tag, intern_color); intern_dest += 1 + Double_wosize; readblock((char *) v, 8); #if ARCH_FLOAT_ENDIANNESS == 0x76543210 if (code != CODE_DOUBLE_BIG) Reverse_64(v, v); #elif ARCH_FLOAT_ENDIANNESS == 0x01234567 if (code != CODE_DOUBLE_LITTLE) Reverse_64(v, v); #else if (code == CODE_DOUBLE_LITTLE) Permute_64(v, ARCH_FLOAT_ENDIANNESS, v, 0x01234567) else Permute_64(v, ARCH_FLOAT_ENDIANNESS, v, 0x76543210); #endif break; case CODE_DOUBLE_ARRAY8_LITTLE: case CODE_DOUBLE_ARRAY8_BIG: len = read8u(); read_double_array: if (sizeof(double) != 8) { intern_cleanup(); caml_invalid_argument("input_value: non-standard floats"); } size = len * Double_wosize; v = Val_hp(intern_dest); if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v; *intern_dest = Make_header(size, Double_array_tag, intern_color); intern_dest += 1 + size; readblock((char *) v, len * 8); #if ARCH_FLOAT_ENDIANNESS == 0x76543210 if (code != CODE_DOUBLE_ARRAY8_BIG && code != CODE_DOUBLE_ARRAY32_BIG) { mlsize_t i; for (i = 0; i < len; i++) Reverse_64((value)((double *)v + i), (value)((double *)v + i)); } #elif ARCH_FLOAT_ENDIANNESS == 0x01234567 if (code != CODE_DOUBLE_ARRAY8_LITTLE && code != CODE_DOUBLE_ARRAY32_LITTLE) { mlsize_t i; for (i = 0; i < len; i++) Reverse_64((value)((double *)v + i), (value)((double *)v + i)); } #else if (code == CODE_DOUBLE_ARRAY8_LITTLE || code == CODE_DOUBLE_ARRAY32_LITTLE) { mlsize_t i; for (i = 0; i < len; i++) Permute_64((value)((double *)v + i), ARCH_FLOAT_ENDIANNESS, (value)((double *)v + i), 0x01234567); } else { mlsize_t i; for (i = 0; i < len; i++) Permute_64((value)((double *)v + i), ARCH_FLOAT_ENDIANNESS, (value)((double *)v + i), 0x76543210); } #endif break; case CODE_DOUBLE_ARRAY32_LITTLE: case CODE_DOUBLE_ARRAY32_BIG: len = read32u(); goto read_double_array; case CODE_CODEPOINTER: ofs = read32u(); readblock(cksum, 16); if (memcmp(cksum, caml_code_checksum(), 16) != 0) { intern_cleanup(); caml_failwith("input_value: code mismatch"); } v = (value) (caml_code_area_start + ofs); break; case CODE_INFIXPOINTER: ofs = read32u(); intern_rec(&clos); v = clos + ofs; break; 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(size, Custom_tag, intern_color); Custom_ops_val(v) = ops; intern_dest += 1 + size; break; default: intern_cleanup(); caml_failwith("input_value: ill-formed message"); } } } *dest = v; } static void intern_alloc(mlsize_t whsize, mlsize_t num_objects) { mlsize_t wosize; if (whsize == 0) { intern_obj_table = NULL; intern_extra_block = NULL; intern_block = 0; return; } wosize = Wosize_whsize(whsize); if (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) caml_raise_out_of_memory(); intern_color = caml_allocation_color(intern_extra_block); intern_dest = (header_t *) intern_extra_block; } else { /* this is a specialised version of caml_alloc from alloc.c */ if (wosize == 0){ intern_block = Atom (String_tag); }else if (wosize <= Max_young_wosize){ intern_block = caml_alloc_small (wosize, String_tag); }else{ intern_block = caml_alloc_shr (wosize, String_tag); /* do not do the urgent_gc check here because it might darken intern_block into gray and break the Assert 3 lines down */ } intern_header = Hd_val(intern_block); intern_color = Color_hd(intern_header); Assert (intern_color == Caml_white || intern_color == Caml_black); intern_dest = (header_t *) Hp_val(intern_block); intern_extra_block = NULL; } obj_counter = 0; if (num_objects > 0) intern_obj_table = (value *) caml_stat_alloc(num_objects * sizeof(value)); else 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 = ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log; header_t * end_extra_block = (header_t *) intern_extra_block + Wsize_bsize(request); Assert(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_add_to_heap(intern_extra_block); } } value caml_input_val(struct channel *chan) { uint32 magic; mlsize_t block_len, num_objects, size_32, size_64, whsize; char * block; value res; if (! caml_channel_binary_mode(chan)) caml_failwith("input_value: not a binary channel"); magic = caml_getword(chan); if (magic != Intext_magic_number) caml_failwith("input_value: bad object"); block_len = caml_getword(chan); num_objects = caml_getword(chan); size_32 = caml_getword(chan); size_64 = caml_getword(chan); /* Read block from channel */ block = caml_stat_alloc(block_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, block_len) == 0) { caml_stat_free(block); caml_failwith("input_value: truncated object"); } intern_input = (unsigned char *) block; intern_input_malloced = 1; intern_src = intern_input; /* Allocate result */ #ifdef ARCH_SIXTYFOUR whsize = size_64; #else whsize = size_32; #endif intern_alloc(whsize, num_objects); /* Fill it in */ intern_rec(&res); intern_add_to_heap(whsize); /* Free everything */ caml_stat_free(intern_input); if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); return res; } 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); } CAMLexport value caml_input_val_from_string(value str, long int ofs) { CAMLparam1 (str); mlsize_t num_objects, size_32, size_64, whsize; CAMLlocal1 (obj); intern_src = &Byte_u(str, ofs + 2*4); intern_input_malloced = 0; num_objects = read32u(); size_32 = read32u(); size_64 = read32u(); /* Allocate result */ #ifdef ARCH_SIXTYFOUR whsize = size_64; #else whsize = size_32; #endif intern_alloc(whsize, num_objects); intern_src = &Byte_u(str, ofs + 5*4); /* If a GC occurred */ /* Fill it in */ intern_rec(&obj); intern_add_to_heap(whsize); /* Free everything */ if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); CAMLreturn (obj); } CAMLprim value caml_input_value_from_string(value str, value ofs) { return caml_input_val_from_string(str, Long_val(ofs)); } static value input_val_from_block(void) { mlsize_t num_objects, size_32, size_64, whsize; value obj; num_objects = read32u(); size_32 = read32u(); size_64 = read32u(); /* Allocate result */ #ifdef ARCH_SIXTYFOUR whsize = size_64; #else whsize = size_32; #endif intern_alloc(whsize, num_objects); /* Fill it in */ intern_rec(&obj); intern_add_to_heap(whsize); /* Free internal data structures */ if (intern_obj_table != NULL) caml_stat_free(intern_obj_table); return obj; } CAMLexport value caml_input_value_from_malloc(char * data, long ofs) { uint32 magic; mlsize_t block_len; value obj; intern_input = (unsigned char *) data; intern_src = intern_input + ofs; intern_input_malloced = 1; magic = read32u(); if (magic != Intext_magic_number) caml_failwith("input_value_from_malloc: bad object"); block_len = read32u(); obj = input_val_from_block(); /* Free the input */ caml_stat_free(intern_input); return obj; } CAMLexport value caml_input_value_from_block(char * data, long len) { uint32 magic; mlsize_t block_len; value obj; intern_input = (unsigned char *) data; intern_src = intern_input; intern_input_malloced = 0; magic = read32u(); if (magic != Intext_magic_number) caml_failwith("input_value_from_block: bad object"); block_len = read32u(); if (5*4 + block_len > len) caml_failwith("input_value_from_block: bad block length"); obj = input_val_from_block(); return obj; } CAMLprim value caml_marshal_data_size(value buff, value ofs) { uint32 magic; mlsize_t block_len; intern_src = &Byte_u(buff, Long_val(ofs)); intern_input_malloced = 0; magic = read32u(); if (magic != Intext_magic_number){ caml_failwith("Marshal.data_size: bad object"); } block_len = read32u(); return Val_long(block_len); } /* Return an MD5 checksum of the code area */ #ifdef NATIVE_CODE #include "md5.h" unsigned char * caml_code_checksum(void) { static unsigned char checksum[16]; static int checksum_computed = 0; if (! checksum_computed) { struct MD5Context ctx; caml_MD5Init(&ctx); caml_MD5Update(&ctx, (unsigned char *) caml_code_area_start, caml_code_area_end - caml_code_area_start); caml_MD5Final(checksum, &ctx); checksum_computed = 1; } return checksum; } #else #include "fix_code.h" unsigned char * caml_code_checksum(void) { return caml_code_md5; } #endif /* 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 caml_deserialize_uint_4(void) { return read32u(); } CAMLexport int32 caml_deserialize_sint_4(void) { return read32s(); } CAMLexport uint64 caml_deserialize_uint_8(void) { uint64 i; caml_deserialize_block_8(&i, 1); return i; } CAMLexport int64 caml_deserialize_sint_8(void) { int64 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, long len) { memmove(data, intern_src, len); intern_src += len; } CAMLexport void caml_deserialize_block_2(void * data, long 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 memmove(data, intern_src, len * 2); intern_src += len * 2; #endif } CAMLexport void caml_deserialize_block_4(void * data, long 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 memmove(data, intern_src, len * 4); intern_src += len * 4; #endif } CAMLexport void caml_deserialize_block_8(void * data, long 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 memmove(data, intern_src, len * 8); intern_src += len * 8; #endif } CAMLexport void caml_deserialize_block_float_8(void * data, long len) { #if ARCH_FLOAT_ENDIANNESS == 0x01234567 memmove(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); }