2016-02-18 07:11:59 -08:00
|
|
|
/**************************************************************************/
|
|
|
|
/* */
|
|
|
|
/* OCaml */
|
|
|
|
/* */
|
|
|
|
/* Damien Doligez, projet Para, 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. */
|
|
|
|
/* */
|
|
|
|
/**************************************************************************/
|
1997-05-13 07:45:38 -07:00
|
|
|
|
2016-07-04 10:00:57 -07:00
|
|
|
#define CAML_INTERNALS
|
|
|
|
|
1997-05-13 07:45:38 -07:00
|
|
|
#include <string.h>
|
|
|
|
|
2015-06-08 06:21:42 -07:00
|
|
|
#include "caml/address_class.h"
|
2014-12-27 06:41:49 -08:00
|
|
|
#include "caml/config.h"
|
|
|
|
#include "caml/finalise.h"
|
|
|
|
#include "caml/freelist.h"
|
|
|
|
#include "caml/gc.h"
|
|
|
|
#include "caml/gc_ctrl.h"
|
|
|
|
#include "caml/major_gc.h"
|
|
|
|
#include "caml/memory.h"
|
|
|
|
#include "caml/mlvalues.h"
|
|
|
|
#include "caml/roots.h"
|
|
|
|
#include "caml/weak.h"
|
2016-06-05 09:13:08 -07:00
|
|
|
#include "caml/compact.h"
|
2019-09-04 05:36:23 -07:00
|
|
|
#include "caml/memprof.h"
|
2019-11-15 04:52:35 -08:00
|
|
|
#include "caml/eventlog.h"
|
1997-05-13 07:45:38 -07:00
|
|
|
|
2005-09-22 07:21:50 -07:00
|
|
|
extern uintnat caml_percent_free; /* major_gc.c */
|
2003-12-31 06:20:40 -08:00
|
|
|
extern void caml_shrink_heap (char *); /* memory.c */
|
1997-05-13 07:45:38 -07:00
|
|
|
|
2020-07-13 01:59:05 -07:00
|
|
|
/* Colors
|
|
|
|
|
|
|
|
We use the GC's color bits in the following way:
|
|
|
|
|
|
|
|
- White words are headers of live blocks.
|
|
|
|
- Blue words are headers of free blocks.
|
|
|
|
- Black words are headers of out-of-heap "blocks".
|
|
|
|
- Gray words are the encoding of pointers in inverted lists.
|
|
|
|
|
|
|
|
Encoded pointers:
|
|
|
|
Pointers always have their two low-order bits clear. We make use of
|
|
|
|
this to encode pointers by shifting bits 2-9 to 0-7:
|
|
|
|
...XXXyyyyyyyy00 becomes ...XXX01yyyyyyyy
|
|
|
|
Note that 01 corresponds to the "gray" color of the GC, so we can now
|
|
|
|
mix pointers and headers because there are no gray headers anywhere in
|
|
|
|
the heap (or outside) when we start a compaction (which must be done at
|
|
|
|
the end of a sweep phase).
|
1997-05-13 07:45:38 -07:00
|
|
|
*/
|
|
|
|
|
2005-09-22 07:21:50 -07:00
|
|
|
typedef uintnat word;
|
1997-05-13 07:45:38 -07:00
|
|
|
|
2020-07-13 01:59:05 -07:00
|
|
|
#define eptr(p) \
|
|
|
|
(((word) (p) & ~0x3FF) | ((((word) p) & 0x3FF) >> 2) | Caml_gray)
|
|
|
|
#define dptr(p) ((word *) (((word) (p) & ~0x3FF) | ((((word) p) & 0xFF) << 2)))
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
static void invert_pointer_at (word *p)
|
1997-05-13 07:45:38 -07:00
|
|
|
{
|
|
|
|
word q = *p;
|
2020-07-13 01:59:05 -07:00
|
|
|
header_t h;
|
|
|
|
|
|
|
|
CAMLassert (((uintnat) p & 3) == 0);
|
|
|
|
|
|
|
|
if (Is_block (q) && Is_in_value_area (q)){
|
|
|
|
h = Hd_val (q);
|
|
|
|
switch (Color_hd (h)){
|
|
|
|
case Caml_white:
|
|
|
|
if (Tag_hd (h) == Infix_tag){
|
|
|
|
value realvalue = (value) q - Infix_offset_val (q);
|
|
|
|
if (Is_black_val (realvalue)) break;
|
1997-05-13 07:45:38 -07:00
|
|
|
}
|
2020-07-13 01:59:05 -07:00
|
|
|
/* FALL THROUGH */
|
|
|
|
case Caml_gray:
|
|
|
|
CAMLassert (Is_in_heap (q));
|
|
|
|
/* [q] points to some inverted list, insert it. */
|
|
|
|
*p = h;
|
|
|
|
Hd_val (q) = eptr (p);
|
|
|
|
break;
|
|
|
|
case Caml_black:
|
|
|
|
/* [q] points to an out-of-heap value. Leave it alone. */
|
1997-05-13 07:45:38 -07:00
|
|
|
break;
|
2020-07-13 01:59:05 -07:00
|
|
|
default: /* Caml_blue */
|
|
|
|
/* We found a pointer to a free block. This cannot happen. */
|
|
|
|
CAMLassert (0);
|
1997-05-13 07:45:38 -07:00
|
|
|
break;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2017-03-07 00:21:41 -08:00
|
|
|
void caml_invert_root (value v, value *p)
|
1997-05-13 07:45:38 -07:00
|
|
|
{
|
2020-07-13 01:59:05 -07:00
|
|
|
#ifdef NO_NAKED_POINTERS
|
|
|
|
/* Note: this assertion will become tautological and should be removed when
|
|
|
|
we finally get rid of the page table in NNP mode.
|
|
|
|
*/
|
|
|
|
CAMLassert (Is_long (*p) || Is_in_heap (*p) || Is_black_val (*p)
|
|
|
|
|| Tag_val (*p) == Infix_tag);
|
|
|
|
#endif
|
1997-05-13 07:45:38 -07:00
|
|
|
invert_pointer_at ((word *) p);
|
|
|
|
}
|
|
|
|
|
|
|
|
static char *compact_fl;
|
|
|
|
|
1997-09-02 05:55:01 -07:00
|
|
|
static void init_compact_allocate (void)
|
1997-05-13 07:45:38 -07:00
|
|
|
{
|
2003-12-31 06:20:40 -08:00
|
|
|
char *ch = caml_heap_start;
|
1997-05-13 07:45:38 -07:00
|
|
|
while (ch != NULL){
|
|
|
|
Chunk_alloc (ch) = 0;
|
|
|
|
ch = Chunk_next (ch);
|
|
|
|
}
|
2003-12-31 06:20:40 -08:00
|
|
|
compact_fl = caml_heap_start;
|
1997-05-13 07:45:38 -07:00
|
|
|
}
|
|
|
|
|
2014-12-12 07:18:04 -08:00
|
|
|
/* [size] is a number of bytes and includes the header size */
|
1997-09-02 05:55:01 -07:00
|
|
|
static char *compact_allocate (mlsize_t size)
|
1997-05-13 07:45:38 -07:00
|
|
|
{
|
|
|
|
char *chunk, *adr;
|
|
|
|
|
|
|
|
while (Chunk_size (compact_fl) - Chunk_alloc (compact_fl) <= Bhsize_wosize (3)
|
1997-05-19 08:42:21 -07:00
|
|
|
&& Chunk_size (Chunk_next (compact_fl))
|
|
|
|
- Chunk_alloc (Chunk_next (compact_fl))
|
1997-05-13 07:45:38 -07:00
|
|
|
<= Bhsize_wosize (3)){
|
|
|
|
compact_fl = Chunk_next (compact_fl);
|
|
|
|
}
|
|
|
|
chunk = compact_fl;
|
|
|
|
while (Chunk_size (chunk) - Chunk_alloc (chunk) < size){
|
2017-03-31 09:20:36 -07:00
|
|
|
chunk = Chunk_next (chunk);
|
|
|
|
CAMLassert (chunk != NULL);
|
1997-05-13 07:45:38 -07:00
|
|
|
}
|
|
|
|
adr = chunk + Chunk_alloc (chunk);
|
|
|
|
Chunk_alloc (chunk) += size;
|
|
|
|
return adr;
|
|
|
|
}
|
|
|
|
|
2019-10-15 04:52:16 -07:00
|
|
|
static void do_compaction (intnat new_allocation_policy)
|
1997-05-13 07:45:38 -07:00
|
|
|
{
|
|
|
|
char *ch, *chend;
|
2017-03-31 09:20:36 -07:00
|
|
|
CAMLassert (caml_gc_phase == Phase_idle);
|
2017-02-27 08:32:44 -08:00
|
|
|
caml_gc_message (0x10, "Compacting heap...\n");
|
1999-11-08 09:31:19 -08:00
|
|
|
|
|
|
|
#ifdef DEBUG
|
2004-01-02 11:23:29 -08:00
|
|
|
caml_heap_check ();
|
1999-11-08 09:31:19 -08:00
|
|
|
#endif
|
|
|
|
|
2020-07-09 05:46:53 -07:00
|
|
|
/* Make sure the heap is in the right state for compaction:
|
|
|
|
- all free blocks are blue
|
|
|
|
- all other blocks are white and contain valid pointers
|
|
|
|
*/
|
|
|
|
caml_fl_reset_and_switch_policy (new_allocation_policy);
|
|
|
|
|
2020-07-13 01:59:05 -07:00
|
|
|
/* First pass: removed in 4.12 thanks to the new closure representation. */
|
1997-05-13 07:45:38 -07:00
|
|
|
|
|
|
|
|
|
|
|
/* Second pass: invert pointers.
|
2020-07-13 01:59:05 -07:00
|
|
|
Don't forget roots and weak pointers.
|
|
|
|
This is a mark-like pass. */
|
1997-05-13 07:45:38 -07:00
|
|
|
{
|
2017-03-07 00:21:41 -08:00
|
|
|
caml_do_roots (caml_invert_root, 1);
|
2016-06-05 09:13:08 -07:00
|
|
|
/* The values to be finalised are not roots but should still be inverted */
|
|
|
|
caml_final_invert_finalisable_values ();
|
2019-09-04 05:36:23 -07:00
|
|
|
/* Idem for memprof tracked blocks */
|
|
|
|
caml_memprof_invert_tracked ();
|
1998-04-06 09:32:33 -07:00
|
|
|
|
2003-12-31 06:20:40 -08:00
|
|
|
ch = caml_heap_start;
|
1997-05-13 07:45:38 -07:00
|
|
|
while (ch != NULL){
|
|
|
|
word *p = (word *) ch;
|
|
|
|
chend = ch + Chunk_size (ch);
|
|
|
|
|
|
|
|
while ((char *) p < chend){
|
1997-05-19 08:42:21 -07:00
|
|
|
word q = *p;
|
2020-07-13 01:59:05 -07:00
|
|
|
mlsize_t wosz, i, first_field;
|
1997-05-19 08:42:21 -07:00
|
|
|
tag_t t;
|
|
|
|
|
2020-07-13 01:59:05 -07:00
|
|
|
while (Is_gray_hd (q)) q = * dptr (q);
|
|
|
|
wosz = Wosize_hd (q);
|
|
|
|
if (Is_white_hd (q)){
|
|
|
|
t = Tag_hd (q);
|
|
|
|
CAMLassert (t != Infix_tag);
|
|
|
|
if (t < No_scan_tag){
|
|
|
|
value v = Val_hp (p);
|
|
|
|
if (t == Closure_tag){
|
|
|
|
first_field = Start_env_closinfo (Closinfo_val (v));
|
|
|
|
}else{
|
|
|
|
first_field = 0;
|
|
|
|
}
|
|
|
|
for (i = first_field; i < wosz; i++){
|
|
|
|
invert_pointer_at ((word *) &Field (v,i));
|
|
|
|
}
|
|
|
|
}
|
1997-05-19 08:42:21 -07:00
|
|
|
}
|
2020-07-13 01:59:05 -07:00
|
|
|
p += Whsize_wosize (wosz);
|
1997-05-13 07:45:38 -07:00
|
|
|
}
|
|
|
|
ch = Chunk_next (ch);
|
|
|
|
}
|
|
|
|
/* Invert weak pointers. */
|
|
|
|
{
|
2013-12-25 11:15:39 -08:00
|
|
|
value *pp = &caml_ephe_list_head;
|
1997-06-02 05:51:51 -07:00
|
|
|
value p;
|
1997-05-13 07:45:38 -07:00
|
|
|
word q;
|
|
|
|
size_t sz, i;
|
|
|
|
|
1997-06-02 05:51:51 -07:00
|
|
|
while (1){
|
|
|
|
p = *pp;
|
|
|
|
if (p == (value) NULL) break;
|
1997-05-19 08:42:21 -07:00
|
|
|
q = Hd_val (p);
|
2020-07-13 01:59:05 -07:00
|
|
|
while (Is_gray_hd (q)) q = * dptr (q);
|
|
|
|
CAMLassert (Is_white_hd (q));
|
|
|
|
sz = Wosize_hd (q);
|
1997-05-19 08:42:21 -07:00
|
|
|
for (i = 1; i < sz; i++){
|
2013-12-25 11:15:39 -08:00
|
|
|
if (Field (p,i) != caml_ephe_none){
|
2003-11-20 13:02:53 -08:00
|
|
|
invert_pointer_at ((word *) &(Field (p,i)));
|
|
|
|
}
|
1997-05-19 08:42:21 -07:00
|
|
|
}
|
1997-09-02 06:13:33 -07:00
|
|
|
invert_pointer_at ((word *) pp);
|
1997-06-02 05:51:51 -07:00
|
|
|
pp = &Field (p, 0);
|
1997-05-13 07:45:38 -07:00
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2020-07-13 01:59:05 -07:00
|
|
|
/* Third pass: reallocate virtually; revert pointers.
|
|
|
|
This is a sweep-like pass. */
|
1997-05-13 07:45:38 -07:00
|
|
|
{
|
|
|
|
init_compact_allocate ();
|
2003-12-31 06:20:40 -08:00
|
|
|
ch = caml_heap_start;
|
1997-05-13 07:45:38 -07:00
|
|
|
while (ch != NULL){
|
|
|
|
word *p = (word *) ch;
|
2008-02-29 04:56:15 -08:00
|
|
|
|
1997-05-13 07:45:38 -07:00
|
|
|
chend = ch + Chunk_size (ch);
|
|
|
|
while ((char *) p < chend){
|
2020-07-13 01:59:05 -07:00
|
|
|
header_t h = Hd_hp (p);
|
|
|
|
size_t sz;
|
2008-02-29 04:56:15 -08:00
|
|
|
|
2020-07-13 01:59:05 -07:00
|
|
|
while (Is_gray_hd (h)) h = * dptr (h);
|
|
|
|
sz = Whsize_hd (h);
|
|
|
|
|
|
|
|
CAMLassert (!Is_black_hd (h));
|
|
|
|
CAMLassert (!Is_gray_hd (h));
|
|
|
|
if (Is_white_hd (h)){
|
|
|
|
word q;
|
1997-05-19 08:42:21 -07:00
|
|
|
tag_t t;
|
|
|
|
char *newadr;
|
2008-02-29 04:56:15 -08:00
|
|
|
|
2020-07-13 01:59:05 -07:00
|
|
|
t = Tag_hd (h);
|
|
|
|
CAMLassert (t != Infix_tag);
|
1997-05-19 08:42:21 -07:00
|
|
|
|
|
|
|
newadr = compact_allocate (Bsize_wsize (sz));
|
|
|
|
q = *p;
|
2020-07-13 01:59:05 -07:00
|
|
|
while (Is_gray_hd (q)){
|
|
|
|
word *pp = dptr (q);
|
|
|
|
q = *pp;
|
|
|
|
*pp = (word) Val_hp (newadr);
|
1997-05-19 08:42:21 -07:00
|
|
|
}
|
2020-07-13 01:59:05 -07:00
|
|
|
CAMLassert (q == h);
|
|
|
|
*p = q;
|
|
|
|
|
|
|
|
if (t == Closure_tag){
|
|
|
|
/* Revert the infix pointers to this block. */
|
|
|
|
mlsize_t i, startenv;
|
|
|
|
value v;
|
|
|
|
|
|
|
|
v = Val_hp (p);
|
|
|
|
startenv = Start_env_closinfo (Closinfo_val (v));
|
|
|
|
i = 0;
|
|
|
|
while (1){
|
|
|
|
int arity = Arity_closinfo (Field (v, i+1));
|
|
|
|
i += 2 + (arity != 0 && arity != 1);
|
|
|
|
if (i >= startenv) break;
|
|
|
|
|
|
|
|
/* Revert the inverted list for infix header at offset [i]. */
|
|
|
|
q = Field (v, i);
|
|
|
|
while (Is_gray_hd (q)){
|
|
|
|
word *pp = dptr (q);
|
|
|
|
q = *pp;
|
|
|
|
*pp = (word) Val_hp ((header_t *) &Field (Val_hp (newadr), i));
|
2017-03-31 09:20:36 -07:00
|
|
|
}
|
2020-07-13 01:59:05 -07:00
|
|
|
CAMLassert (Tag_hd (q) == Infix_tag);
|
|
|
|
Field (v, i) = q;
|
|
|
|
++i;
|
1997-05-19 08:42:21 -07:00
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
2020-07-13 01:59:05 -07:00
|
|
|
p += sz;
|
1997-05-13 07:45:38 -07:00
|
|
|
}
|
|
|
|
ch = Chunk_next (ch);
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* Fourth pass: reallocate and move objects.
|
|
|
|
Use the exact same allocation algorithm as pass 3. */
|
|
|
|
{
|
|
|
|
init_compact_allocate ();
|
2003-12-31 06:20:40 -08:00
|
|
|
ch = caml_heap_start;
|
1997-05-13 07:45:38 -07:00
|
|
|
while (ch != NULL){
|
|
|
|
word *p = (word *) ch;
|
|
|
|
|
|
|
|
chend = ch + Chunk_size (ch);
|
|
|
|
while ((char *) p < chend){
|
1997-05-19 08:42:21 -07:00
|
|
|
word q = *p;
|
2000-01-02 08:10:00 -08:00
|
|
|
if (Color_hd (q) == Caml_white){
|
1997-05-19 08:42:21 -07:00
|
|
|
size_t sz = Bhsize_hd (q);
|
2012-09-10 03:25:18 -07:00
|
|
|
char *newadr = compact_allocate (sz);
|
2000-10-12 11:05:42 -07:00
|
|
|
memmove (newadr, p, sz);
|
1997-05-19 08:42:21 -07:00
|
|
|
p += Wsize_bsize (sz);
|
|
|
|
}else{
|
2017-03-10 08:29:21 -08:00
|
|
|
CAMLassert (Color_hd (q) == Caml_blue);
|
1997-05-19 08:42:21 -07:00
|
|
|
p += Whsize_hd (q);
|
|
|
|
}
|
1997-05-13 07:45:38 -07:00
|
|
|
}
|
|
|
|
ch = Chunk_next (ch);
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Shrink the heap if needed. */
|
|
|
|
{
|
|
|
|
/* Find the amount of live data and the unshrinkable free space. */
|
|
|
|
asize_t live = 0;
|
|
|
|
asize_t free = 0;
|
|
|
|
asize_t wanted;
|
|
|
|
|
2003-12-31 06:20:40 -08:00
|
|
|
ch = caml_heap_start;
|
1997-05-13 07:45:38 -07:00
|
|
|
while (ch != NULL){
|
|
|
|
if (Chunk_alloc (ch) != 0){
|
1997-05-19 08:42:21 -07:00
|
|
|
live += Wsize_bsize (Chunk_alloc (ch));
|
|
|
|
free += Wsize_bsize (Chunk_size (ch) - Chunk_alloc (ch));
|
1997-05-13 07:45:38 -07:00
|
|
|
}
|
|
|
|
ch = Chunk_next (ch);
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Add up the empty chunks until there are enough, then remove the
|
|
|
|
other empty chunks. */
|
2003-12-31 06:20:40 -08:00
|
|
|
wanted = caml_percent_free * (live / 100 + 1);
|
|
|
|
ch = caml_heap_start;
|
1997-05-13 07:45:38 -07:00
|
|
|
while (ch != NULL){
|
|
|
|
char *next_chunk = Chunk_next (ch); /* Chunk_next (ch) will be erased */
|
|
|
|
|
|
|
|
if (Chunk_alloc (ch) == 0){
|
1997-05-19 08:42:21 -07:00
|
|
|
if (free < wanted){
|
1997-05-21 08:28:15 -07:00
|
|
|
free += Wsize_bsize (Chunk_size (ch));
|
1997-05-19 08:42:21 -07:00
|
|
|
}else{
|
2003-12-31 06:20:40 -08:00
|
|
|
caml_shrink_heap (ch);
|
1997-05-19 08:42:21 -07:00
|
|
|
}
|
1997-05-13 07:45:38 -07:00
|
|
|
}
|
|
|
|
ch = next_chunk;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2019-10-15 04:52:16 -07:00
|
|
|
/* Rebuild the free list. This is the right time for a change of
|
|
|
|
allocation policy, since we are rebuilding the allocator's data
|
|
|
|
structures from scratch. */
|
1997-05-13 07:45:38 -07:00
|
|
|
{
|
2003-12-31 06:20:40 -08:00
|
|
|
ch = caml_heap_start;
|
2020-07-09 05:46:53 -07:00
|
|
|
caml_fl_init_merge ();
|
1997-05-13 07:45:38 -07:00
|
|
|
while (ch != NULL){
|
|
|
|
if (Chunk_size (ch) > Chunk_alloc (ch)){
|
2004-01-02 11:23:29 -08:00
|
|
|
caml_make_free_blocks ((value *) (ch + Chunk_alloc (ch)),
|
2012-09-10 03:25:18 -07:00
|
|
|
Wsize_bsize (Chunk_size(ch)-Chunk_alloc(ch)), 1,
|
|
|
|
Caml_white);
|
1997-05-13 07:45:38 -07:00
|
|
|
}
|
|
|
|
ch = Chunk_next (ch);
|
|
|
|
}
|
|
|
|
}
|
2019-06-06 22:00:47 -07:00
|
|
|
++ Caml_state->stat_compactions;
|
2020-09-17 08:24:04 -07:00
|
|
|
|
|
|
|
caml_shrink_mark_stack();
|
|
|
|
|
2017-02-27 08:32:44 -08:00
|
|
|
caml_gc_message (0x10, "done.\n");
|
1997-05-13 07:45:38 -07:00
|
|
|
}
|
|
|
|
|
2008-02-29 04:56:15 -08:00
|
|
|
uintnat caml_percent_max; /* used in gc_ctrl.c and memory.c */
|
1997-05-13 07:45:38 -07:00
|
|
|
|
2019-10-15 04:52:16 -07:00
|
|
|
void caml_compact_heap (intnat new_allocation_policy)
|
2012-04-17 01:21:52 -07:00
|
|
|
{
|
2014-12-24 12:18:22 -08:00
|
|
|
uintnat target_wsz, live;
|
2015-11-20 08:54:26 -08:00
|
|
|
|
2019-06-05 23:39:26 -07:00
|
|
|
CAMLassert (Caml_state->young_ptr == Caml_state->young_alloc_end);
|
2019-08-01 23:28:09 -07:00
|
|
|
CAMLassert (Caml_state->ref_table->ptr ==
|
|
|
|
Caml_state->ref_table->base);
|
|
|
|
CAMLassert (Caml_state->ephe_ref_table->ptr ==
|
|
|
|
Caml_state->ephe_ref_table->base);
|
|
|
|
CAMLassert (Caml_state->custom_table->ptr ==
|
|
|
|
Caml_state->custom_table->base);
|
2012-04-17 01:21:52 -07:00
|
|
|
|
2019-11-15 04:52:35 -08:00
|
|
|
CAML_EV_BEGIN(EV_COMPACT_MAIN);
|
2019-10-15 04:52:16 -07:00
|
|
|
do_compaction (new_allocation_policy);
|
2019-11-15 04:52:35 -08:00
|
|
|
CAML_EV_END(EV_COMPACT_MAIN);
|
2012-04-17 01:21:52 -07:00
|
|
|
/* 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:
|
2014-12-24 12:18:22 -08:00
|
|
|
freewords = caml_fl_cur_wsz (exact)
|
2012-09-10 03:25:18 -07:00
|
|
|
heapwords = Wsize_bsize (caml_heap_size) (exact)
|
|
|
|
live = heapwords - freewords
|
|
|
|
wanted = caml_percent_free * (live / 100 + 1) (same as in do_compaction)
|
2014-12-24 12:18:22 -08:00
|
|
|
target_wsz = live + wanted
|
2012-09-10 03:25:18 -07:00
|
|
|
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).
|
2012-04-17 01:21:52 -07:00
|
|
|
|
2014-12-24 12:18:22 -08:00
|
|
|
We recompact if target_wsz < heap_size / 2
|
2012-04-17 01:21:52 -07:00
|
|
|
*/
|
2019-06-06 22:00:47 -07:00
|
|
|
live = Caml_state->stat_heap_wsz - caml_fl_cur_wsz;
|
2014-12-24 12:18:22 -08:00
|
|
|
target_wsz = live + caml_percent_free * (live / 100 + 1)
|
2012-09-10 03:25:18 -07:00
|
|
|
+ Wsize_bsize (Page_size);
|
2015-11-20 08:54:26 -08:00
|
|
|
target_wsz = caml_clip_heap_chunk_wsz (target_wsz);
|
|
|
|
|
|
|
|
#ifdef HAS_HUGE_PAGES
|
2015-12-02 03:18:41 -08:00
|
|
|
if (caml_use_huge_pages
|
2019-06-06 22:00:47 -07:00
|
|
|
&& Bsize_wsize (Caml_state->stat_heap_wsz) <= HUGE_PAGE_SIZE)
|
2015-12-02 03:18:41 -08:00
|
|
|
return;
|
2015-11-20 08:54:26 -08:00
|
|
|
#endif
|
|
|
|
|
2019-06-06 22:00:47 -07:00
|
|
|
if (target_wsz < Caml_state->stat_heap_wsz / 2){
|
2015-11-20 08:54:26 -08:00
|
|
|
/* Recompact. */
|
2012-04-17 01:21:52 -07:00
|
|
|
char *chunk;
|
|
|
|
|
2017-02-27 08:32:44 -08:00
|
|
|
caml_gc_message (0x10, "Recompacting heap (target=%"
|
|
|
|
ARCH_INTNAT_PRINTF_FORMAT "uk words)\n",
|
2014-12-24 12:18:22 -08:00
|
|
|
target_wsz / 1024);
|
2012-09-10 03:25:18 -07:00
|
|
|
|
2014-12-24 12:18:22 -08:00
|
|
|
chunk = caml_alloc_for_heap (Bsize_wsize (target_wsz));
|
2012-04-17 01:21:52 -07:00
|
|
|
if (chunk == NULL) return;
|
2012-09-10 03:25:18 -07:00
|
|
|
/* PR#5757: we need to make the new blocks blue, or they won't be
|
|
|
|
recognized as free by the recompaction. */
|
2012-04-17 01:21:52 -07:00
|
|
|
caml_make_free_blocks ((value *) chunk,
|
2012-09-10 03:25:18 -07:00
|
|
|
Wsize_bsize (Chunk_size (chunk)), 0, Caml_blue);
|
2012-04-17 01:21:52 -07:00
|
|
|
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;
|
2019-06-06 22:00:47 -07:00
|
|
|
++ Caml_state->stat_heap_chunks;
|
|
|
|
Caml_state->stat_heap_wsz += Wsize_bsize (Chunk_size (chunk));
|
|
|
|
if (Caml_state->stat_heap_wsz > Caml_state->stat_top_heap_wsz){
|
|
|
|
Caml_state->stat_top_heap_wsz = Caml_state->stat_heap_wsz;
|
2012-04-17 01:21:52 -07:00
|
|
|
}
|
2019-11-15 04:52:35 -08:00
|
|
|
CAML_EV_BEGIN(EV_COMPACT_RECOMPACT);
|
2019-10-15 04:52:16 -07:00
|
|
|
do_compaction (-1);
|
2019-06-06 22:00:47 -07:00
|
|
|
CAMLassert (Caml_state->stat_heap_chunks == 1);
|
2017-03-10 08:29:21 -08:00
|
|
|
CAMLassert (Chunk_next (caml_heap_start) == NULL);
|
2019-06-06 22:00:47 -07:00
|
|
|
CAMLassert (Caml_state->stat_heap_wsz == Wsize_bsize (Chunk_size (chunk)));
|
2019-11-15 04:52:35 -08:00
|
|
|
CAML_EV_END(EV_COMPACT_RECOMPACT);
|
2012-04-17 01:21:52 -07:00
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2003-12-31 06:20:40 -08:00
|
|
|
void caml_compact_heap_maybe (void)
|
1997-05-13 07:45:38 -07:00
|
|
|
{
|
2014-12-12 07:18:04 -08:00
|
|
|
/* Estimated free+garbage words in the heap:
|
2014-12-24 12:18:22 -08:00
|
|
|
FW = fl_size_at_phase_change + 3 * (caml_fl_cur_wsz
|
|
|
|
- caml_fl_wsz_at_phase_change)
|
|
|
|
FW = 3 * caml_fl_cur_wsz - 2 * caml_fl_wsz_at_phase_change
|
2019-06-06 22:00:47 -07:00
|
|
|
Estimated live words: LW = Caml_state->stat_heap_wsz - FW
|
2002-05-28 09:57:31 -07:00
|
|
|
Estimated free percentage: FP = 100 * FW / LW
|
2003-12-31 06:20:40 -08:00
|
|
|
We compact the heap if FP > caml_percent_max
|
1997-05-13 07:45:38 -07:00
|
|
|
*/
|
Cleaning up the C code (#1812)
Running Clang 6.0 and GCC 8 with full warnings on suggests a few simple improvements and clean-ups to the C code of OCaml. This commit implements them.
* Remove old-style, unprototyped function declarations
It's `int f(void)`, not `int f()`. [-Wstrict-prototypes]
* Be more explicit about conversions involving `float` and `double`
byterun/bigarray.c, byterun/ints.c:
add explicit casts to clarify the intent
renamed float field of conversion union from `d` to `f`.
byterun/compact.c, byterun/gc_ctrl.c:
some local variables were of type `float` while all FP computations
here are done in double precision;
turned these variables into `double`.
[-Wdouble-promotion -Wfloat-conversion]
*Add explicit initialization of struct field `compare_ext`
[-Wmissing-field-initializers]
* Declare more functions "noreturn"
[-Wmissing-noreturn]
* Make CAMLassert compliant with ISO C
In `e1 ? e2 : e3`, expressions `e2` and `e3` must have the same type.
`e2` of type `void` and `e3` of type `int`, as in the original code,
is a GNU extension.
* Remove or conditionalize unused macros
Some macros were defined and never used.
Some other macros were always defined but conditionally used.
[-Wunused-macros]
* Replace some uses of `int` by more appropriate types like `intnat`
On a 64-bit platform, `int` is only 32 bits and may not represent correctly
the length of a string or the size of an OCaml heap block.
This commit replaces a number of uses of `int` by other types that
are 64-bit wide on 64-bit architectures, such as `intnat` or `uintnat`
or `size_t` or `mlsize_t`.
Sometimes an `intnat` was used as an `int` and is intended as a Boolean
(0 or 1); then it was replaced by an `int`.
There are many remaining cases where we assign a 64-bit quantity to a
32-bit `int` variable. Either I believe these cases are safe
(e.g. the 64-bit quantity is the difference between two pointers
within an I/O buffer, something that always fits in 32 bits), or
the code change was not obvious and too risky.
[-Wshorten-64-to-32]
* Put `inline` before return type
`static inline void f(void)` is cleaner than `static void inline f(void)`.
[-Wold-style-declaration]
* Unused assignment to unused parameter
Looks very useless. [-Wunused-but-set-parameter]
2018-06-07 03:55:09 -07:00
|
|
|
double fw, fp;
|
2017-03-31 09:20:36 -07:00
|
|
|
CAMLassert (caml_gc_phase == Phase_idle);
|
2003-12-31 06:20:40 -08:00
|
|
|
if (caml_percent_max >= 1000000) return;
|
2019-06-06 22:00:47 -07:00
|
|
|
if (Caml_state->stat_major_collections < 3) return;
|
|
|
|
if (Caml_state->stat_heap_wsz <= 2 * caml_clip_heap_chunk_wsz (0)) return;
|
2015-11-20 08:54:26 -08:00
|
|
|
|
|
|
|
#ifdef HAS_HUGE_PAGES
|
2015-12-02 03:18:41 -08:00
|
|
|
if (caml_use_huge_pages
|
2019-06-06 22:00:47 -07:00
|
|
|
&& Bsize_wsize (Caml_state->stat_heap_wsz) <= HUGE_PAGE_SIZE)
|
2015-12-02 03:18:41 -08:00
|
|
|
return;
|
2015-11-20 08:54:26 -08:00
|
|
|
#endif
|
2002-05-28 09:57:31 -07:00
|
|
|
|
2014-12-24 12:18:22 -08:00
|
|
|
fw = 3.0 * caml_fl_cur_wsz - 2.0 * caml_fl_wsz_at_phase_change;
|
|
|
|
if (fw < 0) fw = caml_fl_cur_wsz;
|
2002-05-28 09:57:31 -07:00
|
|
|
|
2019-06-06 22:00:47 -07:00
|
|
|
if (fw >= Caml_state->stat_heap_wsz){
|
2002-05-28 09:57:31 -07:00
|
|
|
fp = 1000000.0;
|
|
|
|
}else{
|
2019-06-06 22:00:47 -07:00
|
|
|
fp = 100.0 * fw / (Caml_state->stat_heap_wsz - fw);
|
2002-05-28 09:57:31 -07:00
|
|
|
if (fp > 1000000.0) fp = 1000000.0;
|
|
|
|
}
|
2005-09-22 07:21:50 -07:00
|
|
|
caml_gc_message (0x200, "FL size at phase change = %"
|
2014-12-24 12:18:22 -08:00
|
|
|
ARCH_INTNAT_PRINTF_FORMAT "u words\n",
|
|
|
|
(uintnat) caml_fl_wsz_at_phase_change);
|
2016-09-27 08:04:51 -07:00
|
|
|
caml_gc_message (0x200, "FL current size = %"
|
|
|
|
ARCH_INTNAT_PRINTF_FORMAT "u words\n",
|
2016-09-28 05:57:50 -07:00
|
|
|
(uintnat) caml_fl_cur_wsz);
|
2005-09-22 07:21:50 -07:00
|
|
|
caml_gc_message (0x200, "Estimated overhead = %"
|
|
|
|
ARCH_INTNAT_PRINTF_FORMAT "u%%\n",
|
|
|
|
(uintnat) fp);
|
2003-12-31 06:20:40 -08:00
|
|
|
if (fp >= caml_percent_max){
|
2017-02-27 08:32:44 -08:00
|
|
|
caml_gc_message (0x200, "Automatic compaction triggered.\n");
|
2015-11-20 08:54:26 -08:00
|
|
|
caml_empty_minor_heap (); /* minor heap must be empty for compaction */
|
2020-10-09 03:02:00 -07:00
|
|
|
caml_gc_message
|
|
|
|
(0x1, "Finishing major GC cycle (triggered by compaction)\n");
|
2003-12-31 06:20:40 -08:00
|
|
|
caml_finish_major_cycle ();
|
2020-06-12 07:42:05 -07:00
|
|
|
++ Caml_state->stat_forced_major_collections;
|
2002-05-28 09:57:31 -07:00
|
|
|
|
2014-12-24 12:18:22 -08:00
|
|
|
fw = caml_fl_cur_wsz;
|
2019-06-06 22:00:47 -07:00
|
|
|
fp = 100.0 * fw / (Caml_state->stat_heap_wsz - fw);
|
2005-09-22 07:21:50 -07:00
|
|
|
caml_gc_message (0x200, "Measured overhead: %"
|
|
|
|
ARCH_INTNAT_PRINTF_FORMAT "u%%\n",
|
|
|
|
(uintnat) fp);
|
2016-09-27 08:04:51 -07:00
|
|
|
if (fp >= caml_percent_max)
|
2019-10-15 04:52:16 -07:00
|
|
|
caml_compact_heap (-1);
|
2016-09-28 05:57:50 -07:00
|
|
|
else
|
2017-02-27 08:32:44 -08:00
|
|
|
caml_gc_message (0x200, "Automatic compaction aborted.\n");
|
2016-09-28 05:57:50 -07:00
|
|
|
|
1997-05-13 07:45:38 -07:00
|
|
|
}
|
|
|
|
}
|