1 |
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc. |
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003 Free Software Foundation, Inc. |
2 |
* |
* |
3 |
* This program is free software; you can redistribute it and/or modify |
* This program is free software; you can redistribute it and/or modify |
4 |
* it under the terms of the GNU General Public License as published by |
* it under the terms of the GNU General Public License as published by |
51 |
#include <stdio.h> |
#include <stdio.h> |
52 |
#include <errno.h> |
#include <errno.h> |
53 |
#include <string.h> |
#include <string.h> |
54 |
|
#include <assert.h> |
55 |
|
|
56 |
#ifdef __ia64__ |
#ifdef __ia64__ |
57 |
#include <ucontext.h> |
#include <ucontext.h> |
241 |
* |
* |
242 |
* INIT_MALLOC_LIMIT is the initial amount of malloc usage which will |
* INIT_MALLOC_LIMIT is the initial amount of malloc usage which will |
243 |
* trigger a GC. |
* trigger a GC. |
|
* |
|
|
* SCM_MTRIGGER_HYSTERESIS is the amount of malloc storage that must be |
|
|
* reclaimed by a GC triggered by must_malloc. If less than this is |
|
|
* reclaimed, the trigger threshold is raised. [I don't know what a |
|
|
* good value is. I arbitrarily chose 1/10 of the INIT_MALLOC_LIMIT to |
|
|
* work around a oscillation that caused almost constant GC.] |
|
244 |
*/ |
*/ |
245 |
|
|
246 |
/* |
/* |
277 |
# define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_t_cell)) |
# define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_t_cell)) |
278 |
# endif |
# endif |
279 |
#endif |
#endif |
280 |
|
|
281 |
/* Make heap grow with factor 1.5 */ |
/* Make heap grow with factor 1.5 */ |
282 |
#define SCM_EXPHEAP(scm_heap_size) (scm_heap_size / 2) |
#define SCM_EXPHEAP(scm_heap_size) (scm_heap_size / 2) |
283 |
#define SCM_INIT_MALLOC_LIMIT 100000 |
|
284 |
#define SCM_MTRIGGER_HYSTERESIS (SCM_INIT_MALLOC_LIMIT/10) |
/* |
285 |
|
At startup GUILE takes about 100k bytes. |
286 |
|
*/ |
287 |
|
#define SCM_INIT_MALLOC_LIMIT 200000 |
288 |
|
|
289 |
/* CELL_UP and CELL_DN are used by scm_init_heap_seg to find (scm_t_cell * span) |
/* CELL_UP and CELL_DN are used by scm_init_heap_seg to find (scm_t_cell * span) |
290 |
aligned inner bounds for allocated storage */ |
aligned inner bounds for allocated storage */ |
313 |
/* scm_freelists |
/* scm_freelists |
314 |
*/ |
*/ |
315 |
|
|
316 |
typedef struct scm_t_freelist { |
typedef struct scm_t_freelist |
317 |
|
{ |
318 |
/* collected cells */ |
/* collected cells */ |
319 |
SCM cells; |
SCM cells; |
320 |
/* number of cells left to collect before cluster is full */ |
/* number of cells left to collect before cluster is full */ |
347 |
* belonging to this list. |
* belonging to this list. |
348 |
*/ |
*/ |
349 |
unsigned long heap_size; |
unsigned long heap_size; |
350 |
} scm_t_freelist; |
} |
351 |
|
scm_t_freelist; |
352 |
|
|
353 |
SCM scm_freelist = SCM_EOL; |
SCM scm_freelist = SCM_EOL; |
354 |
scm_t_freelist scm_master_freelist = { |
scm_t_freelist scm_master_freelist = { |
1939 |
* during garbage collection. |
* during garbage collection. |
1940 |
*/ |
*/ |
1941 |
|
|
1942 |
|
/* |
1943 |
|
* scm_i_minyield_malloc is the minimum expected amount of malloc |
1944 |
|
* storage freed during a GC triggered by scm_must_malloc, etc, in |
1945 |
|
* percent of the size of the malloc heap. When this yield is not |
1946 |
|
* reached, the malloc heap is allowed to grow larger before |
1947 |
|
* triggering the next GC. |
1948 |
|
*/ |
1949 |
|
|
1950 |
|
static int scm_i_minyield_malloc = 40; |
1951 |
|
|
1952 |
|
static void |
1953 |
|
check_mtrigger (char const * what ) |
1954 |
|
{ |
1955 |
|
if (scm_mallocated > scm_mtrigger) |
1956 |
|
{ |
1957 |
|
long prev_alloced = scm_mallocated; |
1958 |
|
float yield; |
1959 |
|
scm_igc (what); |
1960 |
|
yield = (prev_alloced - scm_mallocated) / (float) prev_alloced; |
1961 |
|
|
1962 |
|
if (yield < scm_i_minyield_malloc / 100.0) |
1963 |
|
{ |
1964 |
|
/* |
1965 |
|
If you have a program that builds up a lot of data in |
1966 |
|
strings, then the desired yield will never be satisfied. |
1967 |
|
So we make the trigger a little larger, even. |
1968 |
|
|
1969 |
|
Instead of getting bogged down, we let the mtrigger grow |
1970 |
|
strongly with it. |
1971 |
|
|
1972 |
|
*/ |
1973 |
|
scm_mtrigger = (int)((scm_mallocated * 110.0) |
1974 |
|
/ (100 - scm_i_minyield_malloc)); |
1975 |
|
} |
1976 |
|
} |
1977 |
|
} |
1978 |
|
|
1979 |
/* scm_must_malloc |
/* scm_must_malloc |
1980 |
* Return newly malloced storage or throw an error. |
* Return newly malloced storage or throw an error. |
1981 |
* |
* |
1987 |
* |
* |
1988 |
* The limit scm_mtrigger may be raised by this allocation. |
* The limit scm_mtrigger may be raised by this allocation. |
1989 |
*/ |
*/ |
1990 |
|
|
1991 |
void * |
void * |
1992 |
scm_must_malloc (size_t size, const char *what) |
scm_must_malloc (size_t size, const char *what) |
1993 |
{ |
{ |
1994 |
void *ptr; |
void *ptr; |
1995 |
unsigned long nm = scm_mallocated + size; |
|
1996 |
|
unsigned long nm; |
|
if (nm < size) |
|
|
/* The byte count of allocated objects has overflowed. This is |
|
|
probably because you forgot to report the correct size of freed |
|
|
memory in some of your smob free methods. */ |
|
|
abort (); |
|
|
|
|
|
if (nm <= scm_mtrigger) |
|
|
{ |
|
|
SCM_SYSCALL (ptr = malloc (size)); |
|
|
if (NULL != ptr) |
|
|
{ |
|
|
scm_mallocated = nm; |
|
|
#ifdef GUILE_DEBUG_MALLOC |
|
|
scm_malloc_register (ptr, what); |
|
|
#endif |
|
|
return ptr; |
|
|
} |
|
|
} |
|
|
|
|
|
scm_igc (what); |
|
|
|
|
|
nm = scm_mallocated + size; |
|
1997 |
|
|
1998 |
if (nm < size) |
/* |
1999 |
|
run a slight risk here, in the unlikely event that realloc would |
2000 |
|
return NULL, but wouldn't if we did the GC in check_mtrigger. |
2001 |
|
*/ |
2002 |
|
|
2003 |
|
scm_mallocated += size; |
2004 |
|
SCM_SYSCALL (ptr = malloc (size)); |
2005 |
|
check_mtrigger (what); |
2006 |
|
|
2007 |
|
nm = scm_mallocated; |
2008 |
|
if (nm < size) |
2009 |
/* The byte count of allocated objects has overflowed. This is |
/* The byte count of allocated objects has overflowed. This is |
2010 |
probably because you forgot to report the correct size of freed |
probably because you forgot to report the correct size of freed |
2011 |
memory in some of your smob free methods. */ |
memory in some of your smob free methods. */ |
2012 |
abort (); |
abort (); |
2013 |
|
|
|
SCM_SYSCALL (ptr = malloc (size)); |
|
2014 |
if (NULL != ptr) |
if (NULL != ptr) |
2015 |
{ |
{ |
|
scm_mallocated = nm; |
|
|
if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) { |
|
|
if (nm > scm_mtrigger) |
|
|
scm_mtrigger = nm + nm / 2; |
|
|
else |
|
|
scm_mtrigger += scm_mtrigger / 2; |
|
|
} |
|
2016 |
#ifdef GUILE_DEBUG_MALLOC |
#ifdef GUILE_DEBUG_MALLOC |
2017 |
scm_malloc_register (ptr, what); |
scm_malloc_register (ptr, what); |
2018 |
#endif |
#endif |
|
|
|
2019 |
return ptr; |
return ptr; |
2020 |
} |
} |
2021 |
|
|
2022 |
scm_memory_error (what); |
scm_memory_error (what); |
2023 |
|
assert (0); |
2024 |
|
return NULL; |
2025 |
} |
} |
2026 |
|
|
|
|
|
|
/* scm_must_realloc |
|
|
* is similar to scm_must_malloc. |
|
|
*/ |
|
2027 |
void * |
void * |
2028 |
scm_must_realloc (void *where, |
scm_must_realloc (void *where, |
2029 |
size_t old_size, |
size_t old_size, |
2031 |
const char *what) |
const char *what) |
2032 |
{ |
{ |
2033 |
void *ptr; |
void *ptr; |
2034 |
unsigned long nm; |
|
|
|
|
2035 |
if (size <= old_size) |
if (size <= old_size) |
2036 |
return where; |
return where; |
2037 |
|
|
|
nm = scm_mallocated + size - old_size; |
|
|
|
|
|
if (nm < (size - old_size)) |
|
|
/* The byte count of allocated objects has overflowed. This is |
|
|
probably because you forgot to report the correct size of freed |
|
|
memory in some of your smob free methods. */ |
|
|
abort (); |
|
|
|
|
|
if (nm <= scm_mtrigger) |
|
|
{ |
|
|
SCM_SYSCALL (ptr = realloc (where, size)); |
|
|
if (NULL != ptr) |
|
|
{ |
|
|
scm_mallocated = nm; |
|
|
#ifdef GUILE_DEBUG_MALLOC |
|
|
scm_malloc_reregister (where, ptr, what); |
|
|
#endif |
|
|
return ptr; |
|
|
} |
|
|
} |
|
|
|
|
|
scm_igc (what); |
|
2038 |
|
|
2039 |
nm = scm_mallocated + size - old_size; |
/* |
2040 |
|
run a slight risk here, in the unlikely event that realloc would |
2041 |
if (nm < (size - old_size)) |
return NULL, but wouldn't if we did the GC in check_mtrigger. |
2042 |
|
*/ |
2043 |
|
if (scm_mallocated < 0) |
2044 |
/* The byte count of allocated objects has overflowed. This is |
/* The byte count of allocated objects has overflowed. This is |
2045 |
probably because you forgot to report the correct size of freed |
probably because you forgot to report the correct size of freed |
2046 |
memory in some of your smob free methods. */ |
memory in some of your smob free methods. */ |
2047 |
abort (); |
abort (); |
2048 |
|
|
2049 |
|
/* |
2050 |
|
We don't want to get 0 back if we try to alloc 0 bytes, because |
2051 |
|
scm_must_free() won't take NULL. |
2052 |
|
*/ |
2053 |
|
scm_mallocated += size - old_size; |
2054 |
SCM_SYSCALL (ptr = realloc (where, size)); |
SCM_SYSCALL (ptr = realloc (where, size)); |
2055 |
|
|
2056 |
|
check_mtrigger (what); |
2057 |
|
|
2058 |
if (NULL != ptr) |
if (NULL != ptr) |
2059 |
{ |
{ |
|
scm_mallocated = nm; |
|
|
if (nm > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) { |
|
|
if (nm > scm_mtrigger) |
|
|
scm_mtrigger = nm + nm / 2; |
|
|
else |
|
|
scm_mtrigger += scm_mtrigger / 2; |
|
|
} |
|
2060 |
#ifdef GUILE_DEBUG_MALLOC |
#ifdef GUILE_DEBUG_MALLOC |
2061 |
scm_malloc_reregister (where, ptr, what); |
if(where) |
2062 |
|
scm_malloc_reregister (where, ptr, what); |
2063 |
|
else |
2064 |
|
scm_malloc_register (ptr, what); |
2065 |
#endif |
#endif |
2066 |
return ptr; |
return ptr; |
2067 |
} |
} |
2068 |
|
|
2069 |
scm_memory_error (what); |
scm_memory_error (what); |
2070 |
|
assert(0); |
2071 |
|
return NULL; |
2072 |
} |
} |
2073 |
|
|
2074 |
char * |
char * |
2136 |
} |
} |
2137 |
|
|
2138 |
scm_mallocated += size; |
scm_mallocated += size; |
2139 |
|
check_mtrigger ("foreign mallocs"); |
|
if (scm_mallocated > scm_mtrigger) |
|
|
{ |
|
|
scm_igc ("foreign mallocs"); |
|
|
if (scm_mallocated > scm_mtrigger - SCM_MTRIGGER_HYSTERESIS) |
|
|
{ |
|
|
if (scm_mallocated > scm_mtrigger) |
|
|
scm_mtrigger = scm_mallocated + scm_mallocated / 2; |
|
|
else |
|
|
scm_mtrigger += scm_mtrigger / 2; |
|
|
} |
|
|
} |
|
2140 |
} |
} |
2141 |
|
|
2142 |
void |
void |