static void invert_pointer_at (word *p) { word q = *p; Assert (Ecolor ((intnat) p) == 0); /* Use Ecolor (q) == 0 instead of Is_block (q) because q could be an inverted pointer for an infix header (with Ecolor == 2). */ if (Ecolor (q) == 0 && (Classify_addr (q) & In_heap)) { switch (Ecolor (Hd_val (q))) { case 0: case 3: /* Pointer or header: insert in inverted list. */ *p = Hd_val (q); Hd_val (q) = (header_t) p; break; case 1: /* Infix header: make inverted infix list. */ /* Double inversion: the last of the inverted infix list points to the next infix header in this block. The last of the last list contains the original block header. */ { /* This block as a value. */ value val = (value) q - Infix_offset_val (q); /* Get the block header. */ word *hp = (word *) Hp_val (val); while (Ecolor (*hp) == 0) hp = (word *) *hp; Assert (Ecolor (*hp) == 3); if (Tag_ehd (*hp) == Closure_tag) { /* This is the first infix found in this block. */ /* Save original header. */ *p = *hp; /* Link inverted infix list. */ Hd_val (q) = (header_t) ((word) p | 2); /* Change block header's tag to Infix_tag, and change its size to point to the infix list. */ *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3); } else { Assert (Tag_ehd (*hp) == Infix_tag); /* Point the last of this infix list to the current first infix list of the block. */ *p = (word) &Field (val, Wosize_ehd (*hp)) | 1; /* Point the head of this infix list to the above. */ Hd_val (q) = (header_t) ((word) p | 2); /* Change block header's size to point to this infix list. */ *hp = Make_ehd (Wosize_bhsize (q - val), Infix_tag, 3); } } break; case 2: /* Inverted infix list: insert. */ *p = Hd_val (q); Hd_val (q) = (header_t) ((word) p | 2); break; } } }
value caml_aligned_array_create(size_t alignment, value len) { CAMLparam1 (len); void* bp; mlsize_t bosize; int result; bosize = (Int_val(len) + 1) * alignment; result = posix_memalign(&bp, alignment, bosize); if (result != 0) { if (result == EINVAL) caml_failwith( "The alignment was not a power of two, or was not a multiple of sizeof(void *)"); else if (result == ENOMEM) caml_raise_out_of_memory(); else caml_failwith("Unrecognized error"); } /* Leave space for the header */ bp += alignment; Hd_bp (bp) = Make_header (Wosize_bhsize(Bhsize_bosize(bosize - alignment)), Double_array_tag, Caml_white); CAMLreturn (Val_bp(bp)); }
/* Allocate more memory from malloc for the heap. Return a blue block of at least the requested size. The blue block is chained to a sequence of blue blocks (through their field 0); the last block of the chain is pointed by field 1 of the first. There may be a fragment after the last block. The caller must insert the blocks into the free list. The request must be less than or equal to Max_wosize. Return NULL when out of memory. */ static char *expand_heap (mlsize_t request) { char *mem, *hp, *prev; asize_t over_request, malloc_request, remain; Assert (request <= Max_wosize); over_request = request + request / 100 * caml_percent_free; malloc_request = caml_round_heap_chunk_size (Bhsize_wosize (over_request)); mem = caml_alloc_for_heap (malloc_request); if (mem == NULL){ caml_gc_message (0x04, "No room for growing heap\n", 0); return NULL; } remain = malloc_request; prev = hp = mem; /* FIXME find a way to do this with a call to caml_make_free_blocks */ while (Wosize_bhsize (remain) > Max_wosize){ Hd_hp (hp) = Make_header (Max_wosize, 0, Caml_blue); #ifdef DEBUG caml_set_fields (Bp_hp (hp), 0, Debug_free_major); #endif hp += Bhsize_wosize (Max_wosize); remain -= Bhsize_wosize (Max_wosize); Field (Op_hp (mem), 1) = Field (Op_hp (prev), 0) = (value) Op_hp (hp); prev = hp; } if (remain > 1){ Hd_hp (hp) = Make_header (Wosize_bhsize (remain), 0, Caml_blue); #ifdef DEBUG caml_set_fields (Bp_hp (hp), 0, Debug_free_major); #endif Field (Op_hp (mem), 1) = Field (Op_hp (prev), 0) = (value) Op_hp (hp); Field (Op_hp (hp), 0) = (value) NULL; }else{ Field (Op_hp (prev), 0) = (value) NULL; if (remain == 1) Hd_hp (hp) = Make_header (0, 0, Caml_white); } Assert (Wosize_hp (mem) >= request); if (caml_add_to_heap (mem) != 0){ caml_free_for_heap (mem); return NULL; } return Bp_hp (mem); }
/* Allocate more memory from malloc for the heap. Return a blue block of at least the requested size (in words). The caller must insert the block into the free list. The request must be less than or equal to Max_wosize. Return NULL when out of memory. */ static char *expand_heap (mlsize_t request) { char *mem; asize_t malloc_request; malloc_request = caml_round_heap_chunk_size (Bhsize_wosize (request)); mem = caml_alloc_for_heap (malloc_request); if (mem == NULL){ caml_gc_message (0x04, "No room for growing heap\n", 0); return NULL; } Assert (Wosize_bhsize (malloc_request) >= request); Hd_hp (mem) = Make_header (Wosize_bhsize (malloc_request), 0, Caml_blue); if (caml_add_to_heap (mem) != 0){ caml_free_for_heap (mem); return NULL; } return Bp_hp (mem); }
value netsys_copy_value(value flags, value orig) { int code; int cflags; intnat start_offset, bytelen; mlsize_t wosize; char *dest, *dest_end, *extra_block, *extra_block_end; int color; struct named_custom_ops bigarray_ops; struct named_custom_ops int32_ops; struct named_custom_ops int64_ops; struct named_custom_ops nativeint_ops; CAMLparam2(orig,flags); CAMLlocal1(block); /* First test on trivial cases: */ if (Is_long(orig) || Wosize_val(orig) == 0) { CAMLreturn(orig); }; code = prep_stat_tab(); if (code != 0) goto exit; code = prep_stat_queue(); if (code != 0) goto exit; cflags = caml_convert_flag_list(flags, init_value_flags); /* fprintf (stderr, "counting\n"); */ /* Count only! */ code = netsys_init_value_1(stat_tab, stat_queue, NULL, NULL, orig, (cflags & 1) ? 1 : 0, /* enable_bigarrays */ (cflags & 2) ? 1 : 0, /* enable_customs */ 1, /* enable_atoms */ 1, /* simulate */ NULL, NULL, 0, &start_offset, &bytelen); if (code != 0) goto exit; /* fprintf (stderr, "done counting bytelen=%ld\n", bytelen); */ /* set up the custom ops. We always set this, because we assume that the values in [orig] are not trustworthy */ bigarray_ops.name = "_bigarray"; bigarray_ops.ops = Custom_ops_val(alloc_bigarray_dims(CAML_BA_UINT8 | BIGARRAY_C_LAYOUT, 1, NULL, 1)); bigarray_ops.next = &int32_ops; int32_ops.name = "_i"; int32_ops.ops = Custom_ops_val(caml_copy_int32(0)); int32_ops.next = &int64_ops; int64_ops.name = "_j"; int64_ops.ops = Custom_ops_val(caml_copy_int64(0)); int64_ops.next = &nativeint_ops; nativeint_ops.name = "_n"; nativeint_ops.ops = Custom_ops_val(caml_copy_nativeint(0)); nativeint_ops.next = NULL; /* alloc */ extra_block = NULL; extra_block_end = NULL; /* shamelessly copied from intern.c */ wosize = Wosize_bhsize(bytelen); /* fprintf (stderr, "wosize=%ld\n", wosize); */ if (wosize > Max_wosize) { /* Round desired size up to next page */ asize_t request = ((bytelen + Page_size - 1) >> Page_log) << Page_log; extra_block = caml_alloc_for_heap(request); if (extra_block == NULL) caml_raise_out_of_memory(); extra_block_end = extra_block + request; color = caml_allocation_color(extra_block); dest = extra_block; dest_end = dest + bytelen; block = Val_hp(extra_block); } else {
/* Allocate more memory from malloc for the heap. Return a block of at least the requested size (in words). Return NULL when out of memory. */ static char *expand_heap (mlsize_t request) { char *mem; char *new_page_table = NULL; asize_t new_page_table_size = 0; asize_t malloc_request; asize_t i, more_pages; malloc_request = round_heap_chunk_size (Bhsize_wosize (request)); gc_message ("Growing heap to %ldk\n", (stat_heap_size + malloc_request) / 1024); mem = aligned_malloc (malloc_request + sizeof (heap_chunk_head), sizeof (heap_chunk_head)); if (mem == NULL){ gc_message ("No room for growing heap\n", 0); return NULL; } mem += sizeof (heap_chunk_head); (((heap_chunk_head *) mem) [-1]).size = malloc_request; Assert (Wosize_bhsize (malloc_request) >= request); Hd_hp (mem) = Make_header (Wosize_bhsize (malloc_request), 0, Blue); #ifndef SIXTEEN if (mem < heap_start){ /* This is WRONG, Henning Niss 2005: */ more_pages = -Page (mem); }else if (Page (mem + malloc_request) > page_table_size){ Assert (mem >= heap_end); more_pages = Page (mem + malloc_request) - page_table_size; }else{ more_pages = 0; } if (more_pages != 0){ new_page_table_size = page_table_size + more_pages; new_page_table = (char *) malloc (new_page_table_size); if (new_page_table == NULL){ gc_message ("No room for growing page table\n", 0); free (mem); return NULL; } } if (mem < heap_start){ Assert (more_pages != 0); for (i = 0; i < more_pages; i++){ new_page_table [i] = Not_in_heap; } bcopy (page_table, new_page_table + more_pages, page_table_size); (((heap_chunk_head *) mem) [-1]).next = heap_start; heap_start = mem; }else{ char **last; char *cur; if (mem >= heap_end) heap_end = mem + malloc_request; if (more_pages != 0){ for (i = page_table_size; i < new_page_table_size; i++){ new_page_table [i] = Not_in_heap; } bcopy (page_table, new_page_table, page_table_size); } last = &heap_start; cur = *last; while (cur != NULL && cur < mem){ last = &((((heap_chunk_head *) cur) [-1]).next); cur = *last; } (((heap_chunk_head *) mem) [-1]).next = cur; *last = mem; } if (more_pages != 0){ free (page_table); page_table = new_page_table; page_table_size = new_page_table_size; } #else /* Simplified version for the 8086 */ { char **last; char *cur; last = &heap_start; cur = *last; while (cur != NULL && (char huge *) cur < (char huge *) mem){ last = &((((heap_chunk_head *) cur) [-1]).next); cur = *last; } (((heap_chunk_head *) mem) [-1]).next = cur; *last = mem; } #endif for (i = Page (mem); i < Page (mem + malloc_request); i++){ page_table [i] = In_heap; } stat_heap_size += malloc_request; return Bp_hp (mem); }
/* Allocate more memory from malloc for the heap. Return a block of at least the requested size (in words). Return NULL when out of memory. */ static char *expand_heap (mlsize_t request) { char *mem; char *new_page_table = NULL; size_t new_page_table_size = 0; size_t malloc_request; size_t i, more_pages; malloc_request = round_heap_chunk_size (Bhsize_wosize (request)); gc_message ("Growing heap to %ldk\n", (stat_heap_size + malloc_request) / 1024); mem = aligned_malloc (malloc_request + sizeof (heap_chunk_head), sizeof (heap_chunk_head)); if (mem == NULL){ gc_message ("No room for growing heap\n", 0); return NULL; } mem += sizeof (heap_chunk_head); (((heap_chunk_head *) mem) [-1]).size = malloc_request; assert (Wosize_bhsize (malloc_request) >= request); Hd_hp (mem) = Make_header (Wosize_bhsize (malloc_request), 0, Blue); /* The else if check here can never be negative since have mem >= heap_start * so the Page calculation will be positive. Hence the (unsigned) cast is valid */ if (mem < heap_start) { more_pages = -Page (mem); } else if ((unsigned) Page(mem + malloc_request) > page_table_size) { assert (mem >= heap_end); more_pages = Page (mem + malloc_request) - page_table_size; } else { more_pages = 0; } if (more_pages != 0) { new_page_table_size = page_table_size + more_pages; new_page_table = (char *) malloc (new_page_table_size); if (new_page_table == NULL){ gc_message ("No room for growing page table\n", 0); free (mem); return NULL; } } if (mem < heap_start) { assert (more_pages != 0); for (i = 0; i < more_pages; i++){ new_page_table [i] = Not_in_heap; } bcopy (page_table, new_page_table + more_pages, page_table_size); (((heap_chunk_head *) mem) [-1]).next = heap_start; heap_start = mem; } else { char **last; char *cur; if (mem >= heap_end) heap_end = mem + malloc_request; if (more_pages != 0) { for (i = page_table_size; i < new_page_table_size; i++) { new_page_table [i] = Not_in_heap; } bcopy (page_table, new_page_table, page_table_size); } last = &heap_start; cur = *last; while (cur != NULL && cur < mem){ last = &((((heap_chunk_head *) cur) [-1]).next); cur = *last; } (((heap_chunk_head *) mem) [-1]).next = cur; *last = mem; } if (more_pages != 0) { free (page_table); page_table = new_page_table; page_table_size = new_page_table_size; } for (i = Page (mem); i < (unsigned) Page (mem + malloc_request); i++){ page_table [i] = In_heap; } stat_heap_size += malloc_request; return Bp_hp (mem); }