void caml_compact_heap (void)
{
uintnat target_size, live;
do_compaction ();
/* Compaction may fail to shrink the heap to a reasonable size
because it deals in complete chunks: if a very large chunk
is at the beginning of the heap, everything gets moved to
it and it is not freed.
In that case, we allocate a new chunk of the desired heap
size, chain it at the beginning of the heap (thus pretending
its address is smaller), and launch a second compaction.
This will move all data to this new chunk and free the
very large chunk.
See PR#5389
*/
/* We compute:
freewords = caml_fl_cur_size (exact)
heapsize = caml_heap_size (exact)
live = heap_size - freewords
target_size = live * (1 + caml_percent_free / 100)
= live / 100 * (100 + caml_percent_free)
We add 1 to live/100 to make sure it isn't 0.
We recompact if target_size < heap_size / 2
*/
live = caml_stat_heap_size - Bsize_wsize (caml_fl_cur_size);
target_size = (live / 100 + 1) * (100 + caml_percent_free);
target_size = caml_round_heap_chunk_size (target_size);
if (target_size < caml_stat_heap_size / 2) {
char *chunk;
/* round it up to a page size */
chunk = caml_alloc_for_heap (target_size);
if (chunk == NULL) return;
caml_make_free_blocks ((value *) chunk,
Wsize_bsize (Chunk_size (chunk)), 0);
if (caml_page_table_add (In_heap, chunk, chunk + Chunk_size (chunk)) != 0) {
caml_free_for_heap (chunk);
return;
}
Chunk_next (chunk) = caml_heap_start;
caml_heap_start = chunk;
++ caml_stat_heap_chunks;
caml_stat_heap_size += Chunk_size (chunk);
if (caml_stat_heap_size > caml_stat_top_heap_size) {
caml_stat_top_heap_size = caml_stat_heap_size;
}
do_compaction ();
Assert (caml_stat_heap_chunks == 1);
Assert (Chunk_next (caml_heap_start) == NULL);
}
}
/* 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.
[request] is a number of words and must be less than or equal
to [Max_wosize].
Return NULL when out of memory.
*/
static value *expand_heap (mlsize_t request)
{
/* these point to headers, but we do arithmetic on them, hence [value *]. */
value *mem, *hp, *prev;
asize_t over_request, malloc_request, remain;
Assert (request <= Max_wosize);
over_request = Whsize_wosize (request + request / 100 * caml_percent_free);
malloc_request = caml_round_heap_chunk_wsz (over_request);
mem = (value *) caml_alloc_for_heap (Bsize_wsize (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_whsize (remain) > Max_wosize){
Hd_hp (hp) = Make_header (Max_wosize, 0, Caml_blue);
#ifdef DEBUG
caml_set_fields (Val_hp (hp), 0, Debug_free_major);
#endif
hp += Whsize_wosize (Max_wosize);
remain -= Whsize_wosize (Max_wosize);
Field (Val_hp (mem), 1) = Field (Val_hp (prev), 0) = Val_hp (hp);
prev = hp;
}
if (remain > 1){
Hd_hp (hp) = Make_header (Wosize_whsize (remain), 0, Caml_blue);
#ifdef DEBUG
caml_set_fields (Val_hp (hp), 0, Debug_free_major);
#endif
Field (Val_hp (mem), 1) = Field (Val_hp (prev), 0) = Val_hp (hp);
Field (Val_hp (hp), 0) = (value) NULL;
}else{
Field (Val_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 ((char *) mem) != 0){
caml_free_for_heap ((char *) mem);
return NULL;
}
return Op_hp (mem);
}
/* 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);
}
/* Remove the heap chunk [chunk] from the heap and give the memory back
to [free].
*/
void caml_shrink_heap (char *chunk)
{
char **cp;
asize_t i;
/* Never deallocate the first block, 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.
(see compact.c)
*/
if (chunk == caml_heap_start) return;
caml_stat_heap_size -= Chunk_size (chunk);
caml_gc_message (0x04, "Shrinking heap to %luk bytes\n",
caml_stat_heap_size / 1024);
#ifdef DEBUG
{
mlsize_t i;
for (i = 0; i < Wsize_bsize (Chunk_size (chunk)); i++){
((value *) chunk) [i] = Debug_free_shrink;
}
}
#endif
-- caml_stat_heap_chunks;
/* Remove [chunk] from the list of chunks. */
cp = &caml_heap_start;
while (*cp != chunk) cp = &(Chunk_next (*cp));
*cp = Chunk_next (chunk);
/* Remove the pages of [chunk] from the page table. */
for (i = Page (chunk); i < Page (chunk + Chunk_size (chunk)); i++){
caml_page_table [i] = Not_in_heap;
}
/* Free the [malloc] block that contains [chunk]. */
caml_free_for_heap (chunk);
}
/* Remove the heap chunk [chunk] from the heap and give the memory back
to [free].
*/
void caml_shrink_heap (char *chunk)
{
char **cp;
/* 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.
(see compact.c)
XXX FIXME this has become false with the fix to PR#5389 (see compact.c)
*/
if (chunk == caml_heap_start) return;
caml_stat_heap_wsz -= Wsize_bsize (Chunk_size (chunk));
caml_gc_message (0x04, "Shrinking heap to %luk words\n",
(unsigned long) caml_stat_heap_wsz / 1024);
#ifdef DEBUG
{
mlsize_t i;
for (i = 0; i < Wsize_bsize (Chunk_size (chunk)); i++){
((value *) chunk) [i] = Debug_free_shrink;
}
}
#endif
-- caml_stat_heap_chunks;
/* Remove [chunk] from the list of chunks. */
cp = &caml_heap_start;
while (*cp != chunk) cp = &(Chunk_next (*cp));
*cp = Chunk_next (chunk);
/* Remove the pages of [chunk] from the page table. */
caml_page_table_remove(In_heap, chunk, chunk + Chunk_size (chunk));
/* Free the [malloc] block that contains [chunk]. */
caml_free_for_heap (chunk);
}
void caml_compact_heap_r (CAML_R)
{
uintnat target_words, target_size, live;
do_compaction_r (ctx);
/* Compaction may fail to shrink the heap to a reasonable size
because it deals in complete chunks: if a very large chunk
is at the beginning of the heap, everything gets moved to
it and it is not freed.
In that case, we allocate a new chunk of the desired heap
size, chain it at the beginning of the heap (thus pretending
its address is smaller), and launch a second compaction.
This will move all data to this new chunk and free the
very large chunk.
See PR#5389
*/
/* We compute:
freewords = caml_fl_cur_size (exact)
heapwords = Wsize_bsize (caml_heap_size) (exact)
live = heapwords - freewords
wanted = caml_percent_free * (live / 100 + 1) (same as in do_compaction)
target_words = live + wanted
We add one page to make sure a small difference in counting sizes
won't make [do_compaction] keep the second block (and break all sorts
of invariants).
We recompact if target_size < heap_size / 2
*/
live = Wsize_bsize (caml_stat_heap_size) - caml_fl_cur_size;
target_words = live + caml_percent_free * (live / 100 + 1)
+ Wsize_bsize (Page_size);
target_size = caml_round_heap_chunk_size_r (ctx, Bsize_wsize (target_words));
if (target_size < caml_stat_heap_size / 2){
char *chunk;
caml_gc_message (0x10, "Recompacting heap (target=%luk)\n",
target_size / 1024);
chunk = caml_alloc_for_heap (target_size);
if (chunk == NULL) return;
/* PR#5757: we need to make the new blocks blue, or they won't be
recognized as free by the recompaction. */
caml_make_free_blocks_r (ctx, (value *) chunk,
Wsize_bsize (Chunk_size (chunk)), 0, Caml_blue);
if (caml_page_table_add_r (ctx, In_heap, chunk, chunk + Chunk_size (chunk)) != 0){
caml_free_for_heap (chunk);
return;
}
Chunk_next (chunk) = caml_heap_start;
caml_heap_start = chunk;
++ caml_stat_heap_chunks;
caml_stat_heap_size += Chunk_size (chunk);
if (caml_stat_heap_size > caml_stat_top_heap_size){
caml_stat_top_heap_size = caml_stat_heap_size;
}
do_compaction_r (ctx);
Assert (caml_stat_heap_chunks == 1);
Assert (Chunk_next (caml_heap_start) == NULL);
Assert (caml_stat_heap_size == Chunk_size (chunk));
}
}