1 /**************************************************************************/
2 /* */
3 /* OCaml */
4 /* */
5 /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
6 /* */
7 /* Copyright 1996 Institut National de Recherche en Informatique et */
8 /* en Automatique. */
9 /* */
10 /* All rights reserved. This file is distributed under the terms of */
11 /* the GNU Lesser General Public License version 2.1, with the */
12 /* special exception on linking described in the file LICENSE. */
13 /* */
14 /**************************************************************************/
15
16 #define CAML_INTERNALS
17
18 /* Structured input, compact format */
19
20 /* The interface of this file is "caml/intext.h" */
21
22 #include <string.h>
23 #include <stdio.h>
24 #include "caml/alloc.h"
25 #include "caml/callback.h"
26 #include "caml/config.h"
27 #include "caml/custom.h"
28 #include "caml/fail.h"
29 #include "caml/gc.h"
30 #include "caml/intext.h"
31 #include "caml/io.h"
32 #include "caml/md5.h"
33 #include "caml/memory.h"
34 #include "caml/memprof.h"
35 #include "caml/mlvalues.h"
36 #include "caml/misc.h"
37 #include "caml/reverse.h"
38 #include "caml/signals.h"
39
40
41 static unsigned char * intern_src;
42 /* Reading pointer in block holding input data. */
43
44 static unsigned char * intern_input = NULL;
45 /* Pointer to beginning of block holding input data,
46 if non-NULL this pointer will be freed by the cleanup function. */
47
48 static header_t * intern_dest;
49 /* Writing pointer in destination block */
50
51 static char * intern_extra_block = NULL;
52 /* If non-NULL, point to new heap chunk allocated with caml_alloc_for_heap. */
53
54 static asize_t obj_counter;
55 /* Count how many objects seen so far */
56
57 static value * intern_obj_table = NULL;
58 /* The pointers to objects already seen */
59
60 static color_t intern_color;
61 /* Color to assign to newly created headers */
62
63 static header_t intern_header;
64 /* Original header of the destination block.
65 Meaningful only if intern_extra_block is NULL. */
66
67 static value intern_block = 0;
68 /* Point to the heap block allocated as destination block.
69 Meaningful only if intern_extra_block is NULL. */
70
71 static char * intern_resolve_code_pointer(unsigned char digest[16],
72 asize_t offset);
73
74 CAMLnoreturn_start
75 static void intern_bad_code_pointer(unsigned char digest[16])
76 CAMLnoreturn_end;
77
78 static void intern_free_stack(void);
79
80 static inline unsigned char read8u(void)
81 { return *intern_src++; }
82
83 static inline signed char read8s(void)
84 { return *intern_src++; }
85
86 static inline uint16_t read16u(void)
87 {
88 uint16_t res = (intern_src[0] << 8) + intern_src[1];
89 intern_src += 2;
90 return res;
91 }
92
93 static inline int16_t read16s(void)
94 {
95 int16_t res = (intern_src[0] << 8) + intern_src[1];
96 intern_src += 2;
97 return res;
98 }
99
100 static inline uint32_t read32u(void)
101 {
102 uint32_t res =
103 ((uint32_t)(intern_src[0]) << 24) + (intern_src[1] << 16)
104 + (intern_src[2] << 8) + intern_src[3];
105 intern_src += 4;
106 return res;
107 }
108
109 static inline int32_t read32s(void)
110 {
111 int32_t res =
112 ((uint32_t)(intern_src[0]) << 24) + (intern_src[1] << 16)
113 + (intern_src[2] << 8) + intern_src[3];
114 intern_src += 4;
115 return res;
116 }
117
118 #ifdef ARCH_SIXTYFOUR
119 static uintnat read64u(void)
120 {
121 uintnat res =
122 ((uintnat) (intern_src[0]) << 56)
123 + ((uintnat) (intern_src[1]) << 48)
124 + ((uintnat) (intern_src[2]) << 40)
125 + ((uintnat) (intern_src[3]) << 32)
126 + ((uintnat) (intern_src[4]) << 24)
127 + ((uintnat) (intern_src[5]) << 16)
128 + ((uintnat) (intern_src[6]) << 8)
129 + (uintnat) (intern_src[7]);
130 intern_src += 8;
131 return res;
132 }
133 #endif
134
135 static inline void readblock(void * dest, intnat len)
136 {
137 memcpy(dest, intern_src, len);
138 intern_src += len;
139 }
140
141 static void intern_init(void * src, void * input)
142 {
143 /* This is asserted at the beginning of demarshaling primitives.
144 If it fails, it probably means that an exception was raised
145 without calling intern_cleanup() during the previous demarshaling. */
146 CAMLassert (intern_input == NULL && intern_obj_table == NULL \
147 && intern_extra_block == NULL && intern_block == 0);
148 intern_src = src;
149 intern_input = input;
150 }
151
152 static void intern_cleanup(void)
153 {
154 if (intern_input != NULL) {
155 caml_stat_free(intern_input);
156 intern_input = NULL;
157 }
158 if (intern_obj_table != NULL) {
159 caml_stat_free(intern_obj_table);
160 intern_obj_table = NULL;
161 }
162 if (intern_extra_block != NULL) {
163 /* free newly allocated heap chunk */
164 caml_free_for_heap(intern_extra_block);
165 intern_extra_block = NULL;
166 } else if (intern_block != 0) {
167 /* restore original header for heap block, otherwise GC is confused */
168 Hd_val(intern_block) = intern_header;
169 intern_block = 0;
170 }
171 /* free the recursion stack */
172 intern_free_stack();
173 }
174
175 static void readfloat(double * dest, unsigned int code)
176 {
177 if (sizeof(double) != 8) {
178 intern_cleanup();
179 caml_invalid_argument("input_value: non-standard floats");
180 }
181 readblock((char *) dest, 8);
182 /* Fix up endianness, if needed */
183 #if ARCH_FLOAT_ENDIANNESS == 0x76543210
184 /* Host is big-endian; fix up if data read is little-endian */
185 if (code != CODE_DOUBLE_BIG) Reverse_64(dest, dest);
186 #elif ARCH_FLOAT_ENDIANNESS == 0x01234567
187 /* Host is little-endian; fix up if data read is big-endian */
188 if (code != CODE_DOUBLE_LITTLE) Reverse_64(dest, dest);
189 #else
190 /* Host is neither big nor little; permute as appropriate */
191 if (code == CODE_DOUBLE_LITTLE)
192 Permute_64(dest, ARCH_FLOAT_ENDIANNESS, dest, 0x01234567)
193 else
194 Permute_64(dest, ARCH_FLOAT_ENDIANNESS, dest, 0x76543210);
195 #endif
196 }
197
198 /* [len] is a number of floats */
199 static void readfloats(double * dest, mlsize_t len, unsigned int code)
200 {
201 mlsize_t i;
202 if (sizeof(double) != 8) {
203 intern_cleanup();
204 caml_invalid_argument("input_value: non-standard floats");
205 }
206 readblock((char *) dest, len * 8);
207 /* Fix up endianness, if needed */
208 #if ARCH_FLOAT_ENDIANNESS == 0x76543210
209 /* Host is big-endian; fix up if data read is little-endian */
210 if (code != CODE_DOUBLE_ARRAY8_BIG &&
211 code != CODE_DOUBLE_ARRAY32_BIG) {
212 for (i = 0; i < len; i++) Reverse_64(dest + i, dest + i);
213 }
214 #elif ARCH_FLOAT_ENDIANNESS == 0x01234567
215 /* Host is little-endian; fix up if data read is big-endian */
216 if (code != CODE_DOUBLE_ARRAY8_LITTLE &&
217 code != CODE_DOUBLE_ARRAY32_LITTLE) {
218 for (i = 0; i < len; i++) Reverse_64(dest + i, dest + i);
219 }
220 #else
221 /* Host is neither big nor little; permute as appropriate */
222 if (code == CODE_DOUBLE_ARRAY8_LITTLE ||
223 code == CODE_DOUBLE_ARRAY32_LITTLE) {
224 for (i = 0; i < len; i++)
225 Permute_64(dest + i, ARCH_FLOAT_ENDIANNESS, dest + i, 0x01234567);
226 } else {
227 for (i = 0; i < len; i++)
228 Permute_64(dest + i, ARCH_FLOAT_ENDIANNESS, dest + i, 0x76543210);
229 }
230 #endif
231 }
232
233 /* Item on the stack with defined operation */
234 struct intern_item {
235 value * dest;
236 intnat arg;
237 enum {
238 OReadItems, /* read arg items and store them in dest[0], dest[1], ... */
239 OFreshOID, /* generate a fresh OID and store it in *dest */
240 OShift /* offset *dest by arg */
241 } op;
242 };
243
244 /* FIXME: This is duplicated in two other places, with the only difference of
245 the type of elements stored in the stack. Possible solution in C would
246 be to instantiate stack these function via. C preprocessor macro.
247 */
248
249 #define INTERN_STACK_INIT_SIZE 256
250 #define INTERN_STACK_MAX_SIZE (1024*1024*100)
251
252 static struct intern_item intern_stack_init[INTERN_STACK_INIT_SIZE];
253
254 static struct intern_item * intern_stack = intern_stack_init;
255 static struct intern_item * intern_stack_limit = intern_stack_init
256 + INTERN_STACK_INIT_SIZE;
257
258 /* Free the recursion stack if needed */
259 static void intern_free_stack(void)
260 {
261 if (intern_stack != intern_stack_init) {
262 caml_stat_free(intern_stack);
263 /* Reinitialize the globals for next time around */
264 intern_stack = intern_stack_init;
265 intern_stack_limit = intern_stack + INTERN_STACK_INIT_SIZE;
266 }
267 }
268
269 /* Same, then raise Out_of_memory */
270 CAMLnoreturn_start
271 static void intern_stack_overflow(void)
272 CAMLnoreturn_end;
273
274 static void intern_stack_overflow(void)
275 {
276 caml_gc_message (0x04, "Stack overflow in un-marshaling value\n");
277 intern_free_stack();
278 caml_raise_out_of_memory();
279 }
280
281 static struct intern_item * intern_resize_stack(struct intern_item * sp)
282 {
283 asize_t newsize = 2 * (intern_stack_limit - intern_stack);
284 asize_t sp_offset = sp - intern_stack;
285 struct intern_item * newstack;
286
287 if (newsize >= INTERN_STACK_MAX_SIZE) intern_stack_overflow();
288 if (intern_stack == intern_stack_init) {
289 newstack = caml_stat_alloc_noexc(sizeof(struct intern_item) * newsize);
290 if (newstack == NULL) intern_stack_overflow();
291 memcpy(newstack, intern_stack_init,
292 sizeof(struct intern_item) * INTERN_STACK_INIT_SIZE);
293 } else {
294 newstack = caml_stat_resize_noexc(intern_stack,
295 sizeof(struct intern_item) * newsize);
296 if (newstack == NULL) intern_stack_overflow();
297 }
298 intern_stack = newstack;
299 intern_stack_limit = newstack + newsize;
300 return newstack + sp_offset;
301 }
302
303 /* Convenience macros for requesting operation on the stack */
304 #define PushItem() \
305 do { \
306 sp++; \
307 if (sp >= intern_stack_limit) sp = intern_resize_stack(sp); \
308 } while(0)
309
310 #define ReadItems(_dest,_n) \
311 do { \
312 if (_n > 0) { \
313 PushItem(); \
314 sp->op = OReadItems; \
315 sp->dest = _dest; \
316 sp->arg = _n; \
317 } \
318 } while(0)
319
320 static void intern_rec(value *dest)
321 {
322 unsigned int code;
323 tag_t tag;
324 mlsize_t size, len, ofs_ind;
325 value v;
326 asize_t ofs;
327 header_t header;
328 unsigned char digest[16];
329 struct custom_operations * ops;
330 char * codeptr;
331 struct intern_item * sp;
332
333 sp = intern_stack;
334
335 /* Initially let's try to read the first object from the stream */
336 ReadItems(dest, 1);
337
338 /* The un-marshaler loop, the recursion is unrolled */
339 while(sp != intern_stack) {
340
341 /* Interpret next item on the stack */
342 dest = sp->dest;
343 switch (sp->op) {
344 case OFreshOID:
345 /* Refresh the object ID */
346 /* but do not do it for predefined exception slots */
347 if (Long_val(Field((value)dest, 1)) >= 0)
348 caml_set_oo_id((value)dest);
349 /* Pop item and iterate */
350 sp--;
351 break;
352 case OShift:
353 /* Shift value by an offset */
354 *dest += sp->arg;
355 /* Pop item and iterate */
356 sp--;
357 break;
358 case OReadItems:
359 /* Pop item */
360 sp->dest++;
361 if (--(sp->arg) == 0) sp--;
362 /* Read a value and set v to this value */
363 code = read8u();
364 if (code >= PREFIX_SMALL_INT) {
365 if (code >= PREFIX_SMALL_BLOCK) {
366 /* Small block */
367 tag = code & 0xF;
368 size = (code >> 4) & 0x7;
369 read_block:
370 if (size == 0) {
371 v = Atom(tag);
372 } else {
373 v = Val_hp(intern_dest);
374 if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
375 *intern_dest = Make_header_allocated_here(size, tag, intern_color);
376 intern_dest += 1 + size;
377 /* For objects, we need to freshen the oid */
378 if (tag == Object_tag) {
379 CAMLassert(size >= 2);
380 /* Request to read rest of the elements of the block */
381 ReadItems(&Field(v, 2), size - 2);
382 /* Request freshing OID */
383 PushItem();
384 sp->op = OFreshOID;
385 sp->dest = (value*) v;
386 sp->arg = 1;
387 /* Finally read first two block elements: method table and old OID */
388 ReadItems(&Field(v, 0), 2);
389 } else
390 /* If it's not an object then read the contents of the block */
391 ReadItems(&Field(v, 0), size);
392 }
393 } else {
394 /* Small integer */
395 v = Val_int(code & 0x3F);
396 }
397 } else {
398 if (code >= PREFIX_SMALL_STRING) {
399 /* Small string */
400 len = (code & 0x1F);
401 read_string:
402 size = (len + sizeof(value)) / sizeof(value);
403 v = Val_hp(intern_dest);
404 if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
405 *intern_dest = Make_header_allocated_here(size, String_tag, intern_color);
406 intern_dest += 1 + size;
407 Field(v, size - 1) = 0;
408 ofs_ind = Bsize_wsize(size) - 1;
409 Byte(v, ofs_ind) = ofs_ind - len;
410 readblock((char *)String_val(v), len);
411 } else {
412 switch(code) {
413 case CODE_INT8:
414 v = Val_long(read8s());
415 break;
416 case CODE_INT16:
417 v = Val_long(read16s());
418 break;
419 case CODE_INT32:
420 v = Val_long(read32s());
421 break;
422 case CODE_INT64:
423 #ifdef ARCH_SIXTYFOUR
424 v = Val_long((intnat) (read64u()));
425 break;
426 #else
427 intern_cleanup();
428 caml_failwith("input_value: integer too large");
429 break;
430 #endif
431 case CODE_SHARED8:
432 ofs = read8u();
433 read_shared:
434 CAMLassert (ofs > 0);
435 CAMLassert (ofs <= obj_counter);
436 CAMLassert (intern_obj_table != NULL);
437 v = intern_obj_table[obj_counter - ofs];
438 break;
439 case CODE_SHARED16:
440 ofs = read16u();
441 goto read_shared;
442 case CODE_SHARED32:
443 ofs = read32u();
444 goto read_shared;
445 #ifdef ARCH_SIXTYFOUR
446 case CODE_SHARED64:
447 ofs = read64u();
448 goto read_shared;
449 #endif
450 case CODE_BLOCK32:
451 header = (header_t) read32u();
452 tag = Tag_hd(header);
453 size = Wosize_hd(header);
454 goto read_block;
455 #ifdef ARCH_SIXTYFOUR
456 case CODE_BLOCK64:
457 header = (header_t) read64u();
458 tag = Tag_hd(header);
459 size = Wosize_hd(header);
460 goto read_block;
461 #endif
462 case CODE_STRING8:
463 len = read8u();
464 goto read_string;
465 case CODE_STRING32:
466 len = read32u();
467 goto read_string;
468 #ifdef ARCH_SIXTYFOUR
469 case CODE_STRING64:
470 len = read64u();
471 goto read_string;
472 #endif
473 case CODE_DOUBLE_LITTLE:
474 case CODE_DOUBLE_BIG:
475 v = Val_hp(intern_dest);
476 if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
477 *intern_dest = Make_header_allocated_here(Double_wosize, Double_tag,
478 intern_color);
479 intern_dest += 1 + Double_wosize;
480 readfloat((double *) v, code);
481 break;
482 case CODE_DOUBLE_ARRAY8_LITTLE:
483 case CODE_DOUBLE_ARRAY8_BIG:
484 len = read8u();
485 read_double_array:
486 size = len * Double_wosize;
487 v = Val_hp(intern_dest);
488 if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
489 *intern_dest = Make_header_allocated_here(size, Double_array_tag,
490 intern_color);
491 intern_dest += 1 + size;
492 readfloats((double *) v, len, code);
493 break;
494 case CODE_DOUBLE_ARRAY32_LITTLE:
495 case CODE_DOUBLE_ARRAY32_BIG:
496 len = read32u();
497 goto read_double_array;
498 #ifdef ARCH_SIXTYFOUR
499 case CODE_DOUBLE_ARRAY64_LITTLE:
500 case CODE_DOUBLE_ARRAY64_BIG:
501 len = read64u();
502 goto read_double_array;
503 #endif
504 case CODE_CODEPOINTER:
505 ofs = read32u();
506 readblock(digest, 16);
507 codeptr = intern_resolve_code_pointer(digest, ofs);
508 if (codeptr != NULL) {
509 v = (value) codeptr;
510 } else {
511 const value * function_placeholder =
512 caml_named_value ("Debugger.function_placeholder");
513 if (function_placeholder != NULL) {
514 v = *function_placeholder;
515 } else {
516 intern_cleanup();
517 intern_bad_code_pointer(digest);
518 }
519 }
520 break;
521 case CODE_INFIXPOINTER:
522 ofs = read32u();
523 /* Read a value to *dest, then offset *dest by ofs */
524 PushItem();
525 sp->dest = dest;
526 sp->op = OShift;
527 sp->arg = ofs;
528 ReadItems(dest, 1);
529 continue; /* with next iteration of main loop, skipping *dest = v */
530 case CODE_CUSTOM:
531 case CODE_CUSTOM_LEN:
532 case CODE_CUSTOM_FIXED: {
533 ops = caml_find_custom_operations((char *) intern_src);
534 if (ops == NULL) {
535 intern_cleanup();
536 caml_failwith("input_value: unknown custom block identifier");
537 }
538 if (code == CODE_CUSTOM_FIXED && ops->fixed_length == NULL) {
539 intern_cleanup();
540 caml_failwith("input_value: expected a fixed-size custom block");
541 }
542 while (*intern_src++ != 0) /*nothing*/; /*skip identifier*/
543 if (code == CODE_CUSTOM) {
544 /* deprecated */
545 size = ops->deserialize((void *) (intern_dest + 2));
546 } else {
547 uintnat expected_size;
548 #ifdef ARCH_SIXTYFOUR
549 if (code == CODE_CUSTOM_FIXED) {
550 expected_size = ops->fixed_length->bsize_64;
551 } else {
552 intern_src += 4;
553 expected_size = read64u();
554 }
555 #else
556 if (code == CODE_CUSTOM_FIXED) {
557 expected_size = ops->fixed_length->bsize_32;
558 } else {
559 expected_size = read32u();
560 intern_src += 8;
561 }
562 #endif
563 size = ops->deserialize((void *) (intern_dest + 2));
564 if (size != expected_size) {
565 intern_cleanup();
566 caml_failwith(
567 "input_value: incorrect length of serialized custom block");
568 }
569 }
570 size = 1 + (size + sizeof(value) - 1) / sizeof(value);
571 v = Val_hp(intern_dest);
572 if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
573 *intern_dest = Make_header_allocated_here(size, Custom_tag,
574 intern_color);
575 Custom_ops_val(v) = ops;
576
577 if (ops->finalize != NULL && Is_young(v)) {
578 /* Remember that the block has a finalizer. */
579 add_to_custom_table (Caml_state->custom_table, v, 0, 1);
580 }
581
582 intern_dest += 1 + size;
583 break;
584 }
585 default:
586 intern_cleanup();
587 caml_failwith("input_value: ill-formed message");
588 }
589 }
590 }
591 /* end of case OReadItems */
592 *dest = v;
593 break;
594 default:
595 CAMLassert(0);
596 }
597 }
598 /* We are done. Cleanup the stack and leave the function */
599 intern_free_stack();
600 }
601
602 static void intern_alloc(mlsize_t whsize, mlsize_t num_objects,
603 int outside_heap)
604 {
605 mlsize_t wosize;
606
607 if (whsize == 0) {
608 CAMLassert (intern_extra_block == NULL && intern_block == 0
609 && intern_obj_table == NULL);
610 return;
611 }
612 wosize = Wosize_whsize(whsize);
613 if (outside_heap || wosize > Max_wosize) {
614 /* Round desired size up to next page */
615 asize_t request =
616 ((Bsize_wsize(whsize) + Page_size - 1) >> Page_log) << Page_log;
617 intern_extra_block = caml_alloc_for_heap(request);
618 if (intern_extra_block == NULL) {
619 intern_cleanup();
620 caml_raise_out_of_memory();
621 }
622 intern_color =
623 outside_heap ? Caml_black : caml_allocation_color(intern_extra_block);
624 intern_dest = (header_t *) intern_extra_block;
625 CAMLassert (intern_block == 0);
626 } else {
627 /* this is a specialised version of caml_alloc from alloc.c */
628 if (wosize <= Max_young_wosize){
629 if (wosize == 0){
630 intern_block = Atom (String_tag);
631 }else{
632 #define Setup_for_gc
633 #define Restore_after_gc
634 Alloc_small_no_track(intern_block, wosize, String_tag);
635 #undef Setup_for_gc
636 #undef Restore_after_gc
637 }
638 }else{
639 intern_block = caml_alloc_shr_no_track_noexc (wosize, String_tag);
640 /* do not do the urgent_gc check here because it might darken
641 intern_block into gray and break the intern_color assertion below */
642 if (intern_block == 0) {
643 intern_cleanup();
644 caml_raise_out_of_memory();
645 }
646 }
647 intern_header = Hd_val(intern_block);
648 intern_color = Color_hd(intern_header);
649 CAMLassert (intern_color == Caml_white || intern_color == Caml_black);
650 intern_dest = (header_t *) Hp_val(intern_block);
651 CAMLassert (intern_extra_block == NULL);
652 }
653 obj_counter = 0;
654 if (num_objects > 0) {
655 intern_obj_table =
656 (value *) caml_stat_alloc_noexc(num_objects * sizeof(value));
657 if (intern_obj_table == NULL) {
658 intern_cleanup();
659 caml_raise_out_of_memory();
660 }
661 } else
662 CAMLassert(intern_obj_table == NULL);
663 }
664
665 static header_t* intern_add_to_heap(mlsize_t whsize)
666 {
667 header_t* res = NULL;
668 /* Add new heap chunk to heap if needed */
669 if (intern_extra_block != NULL) {
670 /* If heap chunk not filled totally, build free block at end */
671 asize_t request = Chunk_size (intern_extra_block);
672 header_t * end_extra_block =
673 (header_t *) intern_extra_block + Wsize_bsize(request);
674 CAMLassert(intern_block == 0);
675 CAMLassert(intern_dest <= end_extra_block);
676 if (intern_dest < end_extra_block){
677 caml_make_free_blocks ((value *) intern_dest,
678 end_extra_block - intern_dest, 0, Caml_white);
679 }
680 caml_allocated_words +=
681 Wsize_bsize ((char *) intern_dest - intern_extra_block);
682 if(caml_add_to_heap(intern_extra_block) != 0) {
683 intern_cleanup();
684 caml_raise_out_of_memory();
685 }
686 res = (header_t*)intern_extra_block;
687 intern_extra_block = NULL; // To prevent intern_cleanup freeing it
688 } else if(intern_block != 0) { /* [intern_block = 0] when [whsize = 0] */
689 res = Hp_val(intern_block);
690 intern_block = 0; // To prevent intern_cleanup rewriting its header
691 }
692 return res;
693 }
694
695 static value intern_end(value res, mlsize_t whsize)
696 {
697 CAMLparam1(res);
698 header_t *block = intern_add_to_heap(whsize);
699 header_t *blockend = intern_dest;
700
701 /* Free everything */
702 intern_cleanup();
703
704 /* Memprof tracking has to be done here, because unmarshalling can
705 still fail until now. */
706 if(block != NULL)
707 caml_memprof_track_interned(block, blockend);
708
709 // Give gc a chance to run, and run memprof callbacks
710 caml_process_pending_actions();
711
712 CAMLreturn(res);
713 }
714
715 /* Parsing the header */
716
717 struct marshal_header {
718 uint32_t magic;
719 int header_len;
720 uintnat data_len;
721 uintnat num_objects;
722 uintnat whsize;
723 };
724
725 static void caml_parse_header(char * fun_name,
726 /*out*/ struct marshal_header * h)
727 {
728 char errmsg[100];
729
730 h->magic = read32u();
731 switch(h->magic) {
732 case Intext_magic_number_small:
733 h->header_len = 20;
734 h->data_len = read32u();
735 h->num_objects = read32u();
736 #ifdef ARCH_SIXTYFOUR
737 read32u();
738 h->whsize = read32u();
739 #else
740 h->whsize = read32u();
741 read32u();
742 #endif
743 break;
744 case Intext_magic_number_big:
745 #ifdef ARCH_SIXTYFOUR
746 h->header_len = 32;
747 read32u();
748 h->data_len = read64u();
749 h->num_objects = read64u();
750 h->whsize = read64u();
751 #else
752 errmsg[sizeof(errmsg) - 1] = 0;
753 snprintf(errmsg, sizeof(errmsg) - 1,
754 "%s: object too large to be read back on a 32-bit platform",
755 fun_name);
756 caml_failwith(errmsg);
757 #endif
758 break;
759 default:
760 errmsg[sizeof(errmsg) - 1] = 0;
761 snprintf(errmsg, sizeof(errmsg) - 1,
762 "%s: bad object",
763 fun_name);
764 caml_failwith(errmsg);
765 }
766 }
767
768 /* Reading from a channel */
769
770 static value caml_input_val_core(struct channel *chan, int outside_heap)
771 {
772 intnat r;
773 char header[32];
774 struct marshal_header h;
775 char * block;
776 value res;
777
778 if (! caml_channel_binary_mode(chan))
779 caml_failwith("input_value: not a binary channel");
780 /* Read and parse the header */
781 r = caml_really_getblock(chan, header, 20);
782 if (r == 0)
783 caml_raise_end_of_file();
784 else if (r < 20)
785 caml_failwith("input_value: truncated object");
786 intern_src = (unsigned char *) header;
787 if (read32u() == Intext_magic_number_big) {
788 /* Finish reading the header */
789 if (caml_really_getblock(chan, header + 20, 32 - 20) < 32 - 20)
790 caml_failwith("input_value: truncated object");
791 }
792 intern_src = (unsigned char *) header;
793 caml_parse_header("input_value", &h);
794 /* Read block from channel */
795 block = caml_stat_alloc(h.data_len);
796 /* During [caml_really_getblock], concurrent [caml_input_val] operations
797 can take place (via signal handlers or context switching in systhreads),
798 and [intern_input] may change. So, wait until [caml_really_getblock]
799 is over before using [intern_input] and the other global vars. */
800 if (caml_really_getblock(chan, block, h.data_len) < h.data_len) {
801 caml_stat_free(block);
802 caml_failwith("input_value: truncated object");
803 }
804 /* Initialize global state */
805 intern_init(block, block);
806 intern_alloc(h.whsize, h.num_objects, outside_heap);
807 /* Fill it in */
808 intern_rec(&res);
809 if (!outside_heap)
810 return intern_end(res, h.whsize);
811 else {
812 caml_disown_for_heap(intern_extra_block);
813 intern_extra_block = NULL;
814 intern_block = 0;
815 /* Free everything */
816 intern_cleanup();
817 return caml_check_urgent_gc(res);
818 }
819 }
820
821 value caml_input_val(struct channel* chan)
822 {
823 return caml_input_val_core(chan, 0);
824 }
825
826 CAMLprim value caml_input_value(value vchan)
827 {
828 CAMLparam1 (vchan);
829 struct channel * chan = Channel(vchan);
830 CAMLlocal1 (res);
831
832 Lock(chan);
833 res = caml_input_val(chan);
834 Unlock(chan);
835 CAMLreturn (res);
836 }
837
838 /* Reading from memory-resident blocks */
839
840 CAMLprim value caml_input_value_to_outside_heap(value vchan)
841 {
842 CAMLparam1 (vchan);
843 struct channel * chan = Channel(vchan);
844 CAMLlocal1 (res);
845
846 Lock(chan);
847 res = caml_input_val_core(chan, 1);
848 Unlock(chan);
849 CAMLreturn (res);
850 }
851
852 CAMLexport value caml_input_val_from_bytes(value str, intnat ofs)
853 {
854 CAMLparam1 (str);
855 CAMLlocal1 (obj);
856 struct marshal_header h;
857
858 /* Initialize global state */
859 intern_init(&Byte_u(str, ofs), NULL);
860 caml_parse_header("input_val_from_string", &h);
861 if (ofs + h.header_len + h.data_len > caml_string_length(str))
862 caml_failwith("input_val_from_string: bad length");
863 /* Allocate result */
864 intern_alloc(h.whsize, h.num_objects, 0);
865 intern_src = &Byte_u(str, ofs + h.header_len); /* If a GC occurred */
866 /* Fill it in */
867 intern_rec(&obj);
868 CAMLreturn (intern_end(obj, h.whsize));
869 }
870
871 CAMLprim value caml_input_value_from_string(value str, value ofs)
872 {
873 return caml_input_val_from_bytes(str, Long_val(ofs));
874 }
875
876 CAMLprim value caml_input_value_from_bytes(value str, value ofs)
877 {
878 return caml_input_val_from_bytes(str, Long_val(ofs));
879 }
880
881 static value input_val_from_block(struct marshal_header * h)
882 {
883 value obj;
884 /* Allocate result */
885 intern_alloc(h->whsize, h->num_objects, 0);
886 /* Fill it in */
887 intern_rec(&obj);
888 return (intern_end(obj, h->whsize));
889 }
890
891 CAMLexport value caml_input_value_from_malloc(char * data, intnat ofs)
892 {
893 struct marshal_header h;
894
895 intern_init(data + ofs, data);
896
897 caml_parse_header("input_value_from_malloc", &h);
898
899 return input_val_from_block(&h);
900 }
901
902 /* [len] is a number of bytes */
903 CAMLexport value caml_input_value_from_block(char * data, intnat len)
904 {
905 struct marshal_header h;
906
907 /* Initialize global state */
908 intern_init(data, NULL);
909 caml_parse_header("input_value_from_block", &h);
910 if (h.header_len + h.data_len > len)
911 caml_failwith("input_val_from_block: bad length");
912 return input_val_from_block(&h);
913 }
914
915 /* [ofs] is a [value] that represents a number of bytes
916 result is a [value] that represents a number of bytes
917 To handle both the small and the big format,
918 we assume 20 bytes are available at [buff + ofs],
919 and we return the data size + the length of the part of the header
920 that remains to be read. */
921
922 CAMLprim value caml_marshal_data_size(value buff, value ofs)
923 {
924 uint32_t magic;
925 int header_len;
926 uintnat data_len;
927
928 intern_src = &Byte_u(buff, Long_val(ofs));
929 magic = read32u();
930 switch(magic) {
931 case Intext_magic_number_small:
932 header_len = 20;
933 data_len = read32u();
934 break;
935 case Intext_magic_number_big:
936 #ifdef ARCH_SIXTYFOUR
937 header_len = 32;
938 read32u();
939 data_len = read64u();
940 #else
941 caml_failwith("Marshal.data_size: "
942 "object too large to be read back on a 32-bit platform");
943 #endif
944 break;
945 default:
946 caml_failwith("Marshal.data_size: bad object");
947 }
948 return Val_long((header_len - 20) + data_len);
949 }
950
951 /* Resolution of code pointers */
952
953 static char * intern_resolve_code_pointer(unsigned char digest[16],
954 asize_t offset)
955 {
956 int i;
957 for (i = caml_code_fragments_table.size - 1; i >= 0; i--) {
958 struct code_fragment * cf = caml_code_fragments_table.contents[i];
959 if (! cf->digest_computed) {
960 caml_md5_block(cf->digest, cf->code_start, cf->code_end - cf->code_start);
961 cf->digest_computed = 1;
962 }
963 if (memcmp(digest, cf->digest, 16) == 0) {
964 if (cf->code_start + offset < cf->code_end)
965 return cf->code_start + offset;
966 else
967 return NULL;
968 }
969 }
970 return NULL;
971 }
972
973 static void intern_bad_code_pointer(unsigned char digest[16])
974 {
975 char msg[256];
976 snprintf(msg, sizeof(msg),
977 "input_value: unknown code module "
978 "%02X%02X%02X%02X%02X%02X%02X%02X"
979 "%02X%02X%02X%02X%02X%02X%02X%02X",
980 digest[0], digest[1], digest[2], digest[3],
981 digest[4], digest[5], digest[6], digest[7],
982 digest[8], digest[9], digest[10], digest[11],
983 digest[12], digest[13], digest[14], digest[15]);
984 caml_failwith(msg);
985 }
986
987 /* Functions for writing user-defined marshallers */
988
989 CAMLexport int caml_deserialize_uint_1(void)
990 {
991 return read8u();
992 }
993
994 CAMLexport int caml_deserialize_sint_1(void)
995 {
996 return read8s();
997 }
998
999 CAMLexport int caml_deserialize_uint_2(void)
1000 {
1001 return read16u();
1002 }
1003
1004 CAMLexport int caml_deserialize_sint_2(void)
1005 {
1006 return read16s();
1007 }
1008
1009 CAMLexport uint32_t caml_deserialize_uint_4(void)
1010 {
1011 return read32u();
1012 }
1013
1014 CAMLexport int32_t caml_deserialize_sint_4(void)
1015 {
1016 return read32s();
1017 }
1018
1019 CAMLexport uint64_t caml_deserialize_uint_8(void)
1020 {
1021 uint64_t i;
1022 caml_deserialize_block_8(&i, 1);
1023 return i;
1024 }
1025
1026 CAMLexport int64_t caml_deserialize_sint_8(void)
1027 {
1028 int64_t i;
1029 caml_deserialize_block_8(&i, 1);
1030 return i;
1031 }
1032
1033 CAMLexport float caml_deserialize_float_4(void)
1034 {
1035 float f;
1036 caml_deserialize_block_4(&f, 1);
1037 return f;
1038 }
1039
1040 CAMLexport double caml_deserialize_float_8(void)
1041 {
1042 double f;
1043 caml_deserialize_block_float_8(&f, 1);
1044 return f;
1045 }
1046
1047 CAMLexport void caml_deserialize_block_1(void * data, intnat len)
1048 {
1049 memcpy(data, intern_src, len);
1050 intern_src += len;
1051 }
1052
1053 CAMLexport void caml_deserialize_block_2(void * data, intnat len)
1054 {
1055 #ifndef ARCH_BIG_ENDIAN
1056 unsigned char * p, * q;
1057 for (p = intern_src, q = data; len > 0; len--, p += 2, q += 2)
1058 Reverse_16(q, p);
1059 intern_src = p;
1060 #else
1061 memcpy(data, intern_src, len * 2);
1062 intern_src += len * 2;
1063 #endif
1064 }
1065
1066 CAMLexport void caml_deserialize_block_4(void * data, intnat len)
1067 {
1068 #ifndef ARCH_BIG_ENDIAN
1069 unsigned char * p, * q;
1070 for (p = intern_src, q = data; len > 0; len--, p += 4, q += 4)
1071 Reverse_32(q, p);
1072 intern_src = p;
1073 #else
1074 memcpy(data, intern_src, len * 4);
1075 intern_src += len * 4;
1076 #endif
1077 }
1078
1079 CAMLexport void caml_deserialize_block_8(void * data, intnat len)
1080 {
1081 #ifndef ARCH_BIG_ENDIAN
1082 unsigned char * p, * q;
1083 for (p = intern_src, q = data; len > 0; len--, p += 8, q += 8)
1084 Reverse_64(q, p);
1085 intern_src = p;
1086 #else
1087 memcpy(data, intern_src, len * 8);
1088 intern_src += len * 8;
1089 #endif
1090 }
1091
1092 CAMLexport void caml_deserialize_block_float_8(void * data, intnat len)
1093 {
1094 #if ARCH_FLOAT_ENDIANNESS == 0x01234567
1095 memcpy(data, intern_src, len * 8);
1096 intern_src += len * 8;
1097 #elif ARCH_FLOAT_ENDIANNESS == 0x76543210
1098 unsigned char * p, * q;
1099 for (p = intern_src, q = data; len > 0; len--, p += 8, q += 8)
1100 Reverse_64(q, p);
1101 intern_src = p;
1102 #else
1103 unsigned char * p, * q;
1104 for (p = intern_src, q = data; len > 0; len--, p += 8, q += 8)
1105 Permute_64(q, ARCH_FLOAT_ENDIANNESS, p, 0x01234567);
1106 intern_src = p;
1107 #endif
1108 }
1109
1110 CAMLexport void caml_deserialize_error(char * msg)
1111 {
1112 intern_cleanup();
1113 caml_failwith(msg);
1114 }
1115