mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-15 01:10:53 -07:00
Code Issues Projects Releases Packages Wiki Activity

gbc: remove obsolete (non-functional) GC

Browse source 
I would like to bring it back to life in the future, but we have to
clean the interfaces first.
This commit is contained in:
Daniel Kochmański 2016-03-11 13:10:51 +01:00
parent 9b82583884
commit 61500316b7
3 changed files with 0 additions and 1966 deletions
Download patch file Download diff file Expand all files Collapse all files

978
src/c/alloc.d
View file

@ -1,978 +0,0 @@
/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */
/*
alloc.c -- Memory allocation.
*/
/*
Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
Copyright (c) 1990, Giuseppe Attardi.
Copyright (c) 2001, Juan Jose Garcia Ripoll.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../Copyright' for full details.
*/
/********************************************************************************
*** ***
*** IMPORTANT: This is obsolete code. The current garbage collector of ECL ***
*** is the Boehm-Weiser garbage collector and it is dealt with in ***
*** alloc_2.d ***
*** This file is kept here because of historical purposes, but also because ***
*** it might be useful in the future to implement another garbage collector ***
*** ***
********************************************************************************/
/*
Heap and Relocatable Area
heap_end data_end
+------+--------------------+ - - - + - - --------+
| text | heap | hole | stack |
+------+--------------------+ - - - + - - --------+
The type_map array covers all pages of memory: those not used for objects
are marked as type t_other.
The tm_table array holds a struct typemanager for each type, which contains
the first element of the free list for the type, and other bookkeeping
information.
*/
#include <unistd.h>
#include <string.h>
#include <stdio.h>
#include <ecl/ecl.h>
#include <ecl/internal.h>
#include <ecl/page.h>
#define USE_MMAP
#if defined(USE_MMAP)
#include <sys/types.h>
#include <sys/mman.h>
#elif defined(HAVE_ULIMIT_H)
#include <ulimit.h>
#else
#include <sys/resource.h>
#endif
#ifdef ECL_SMALL_CONS
#error "Internal error: ECL cannot be built with --disable-boehm and --enable-smallcons"
#endif
/******************************* EXPORTS ******************************/
cl_index real_maxpage;
cl_index new_holepage;
char type_map[MAXPAGE];
struct typemanager tm_table[(int)t_end];
struct contblock *cb_pointer = NULL;
cl_index ncb; /* number of contblocks */
cl_index ncbpage; /* number of contblock pages */
cl_index maxcbpage; /* maximum number of contblock pages */
cl_index cbgccount; /* contblock gc count */
cl_index holepage; /* hole pages */
cl_ptr heap_end; /* heap end */
cl_ptr heap_start; /* heap start */
cl_ptr data_end; /* end of data space */
/******************************* ------- ******************************/
static bool ignore_maximum_pages = TRUE;
#ifdef NEED_MALLOC
static cl_object malloc_list;
#endif
/*
Ensure that the hole is at least "n" pages large. If it is not,
allocate space from the operating system.
*/
#if defined(USE_MMAP)
void
cl_resize_hole(cl_index n)
{
#define PAGESIZE 8192
cl_index m, bytes;
cl_ptr result, last_addr;
bytes = n * LISP_PAGESIZE;
bytes = (bytes + PAGESIZE-1) / PAGESIZE;
bytes = bytes * PAGESIZE;
if (heap_start == NULL) {
/* First time use. We allocate the memory and keep the first
* address in heap_start.
*/
result = mmap(0x2E000000, bytes, PROT_READ | PROT_WRITE,
MAP_ANON | MAP_FIXED | MAP_PRIVATE, -1 ,0);
if (result == MAP_FAILED)
ecl_internal_error("Cannot allocate memory. Good-bye!");
data_end = heap_end = heap_start = result;
last_addr = heap_start + bytes;
holepage = n;
} else {
/* Next time use. We extend the region of memory that we had
* mapped before.
*/
m = (data_end - heap_end)/LISP_PAGESIZE;
if (n <= m)
return;
result = mmap(data_end, bytes, PROT_READ | PROT_WRITE,
MAP_ANON | MAP_FIXED | MAP_PRIVATE, -1, 0);
if (result == MAP_FAILED)
ecl_internal_error("Cannot resize memory pool. Good-bye!");
last_addr = result + bytes;
if (result != data_end) {
cl_dealloc(heap_end, data_end - heap_end);
while (heap_end < result) {
cl_index p = page(heap_end);
if (p > real_maxpage)
ecl_internal_error("Memory limit exceeded.");
type_map[p] = t_other;
heap_end += LISP_PAGESIZE;
}
}
holepage = (last_addr - heap_end) / LISP_PAGESIZE;
}
while (data_end < last_addr) {
type_map[page(data_end)] = t_other;
data_end += LISP_PAGESIZE;
}
}
#else
void
cl_resize_hole(cl_index n)
{
cl_ptr e;
cl_index m;
m = (data_end - heap_end)/LISP_PAGESIZE;
if (n <= m)
return;
/* Create the hole */
e = sbrk(0);
if (data_end == e) {
e = sbrk((n -= m) * LISP_PAGESIZE);
} else {
cl_dealloc(heap_end, data_end - heap_end);
/* FIXME! Horrible hack! */
/* mark as t_other pages not allocated by us */
heap_end = e;
while (data_end < heap_end) {
type_map[page(data_end)] = t_other;
data_end += LISP_PAGESIZE;
}
holepage = 0;
e = sbrk(n * LISP_PAGESIZE + (data_end - e));
}
if ((cl_fixnum)e < 0)
ecl_internal_error("Can't allocate. Good-bye!");
data_end = e;
holepage += n;
}
#endif
/* Allocates n pages from the hole. */
static void *
alloc_page(cl_index n)
{
cl_ptr e = heap_end;
if (n >= holepage) {
ecl_gc(t_contiguous);
cl_resize_hole(new_holepage+n);
}
holepage -= n;
heap_end += LISP_PAGESIZE*n;
return e;
}
/*
* We have to mark all objects within the page as FREE. However, at
* the end of the page there might be extra bytes, which have to be
* tagged as useless. Since these bytes are at least 4, x->m points to
* data within the page and we can mark this object setting x->m=FREE.
*/
static void
add_page_to_freelist(cl_ptr p, struct typemanager *tm)
{
cl_type t;
cl_object x, f;
cl_index i;
t = tm->tm_type;
type_map[page(p)] = t;
f = tm->tm_free;
for (i = tm->tm_nppage; i > 0; --i, p += tm->tm_size) {
x = (cl_object)p;
((struct freelist *)x)->t = (short)t;
((struct freelist *)x)->m = FREE;
((struct freelist *)x)->f_link = f;
f = x;
}
/* Mark the extra bytes which cannot be used. */
if (tm->tm_size * tm->tm_nppage < LISP_PAGESIZE) {
x = (cl_object)p;
x->d.m = FREE;
}
tm->tm_free = f;
tm->tm_nfree += tm->tm_nppage;
tm->tm_npage++;
}
cl_object
ecl_alloc_object(cl_type t)
{
register cl_object obj;
register struct typemanager *tm;
register cl_ptr p;
switch (t) {
case t_fixnum:
return MAKE_FIXNUM(0); /* Immediate fixnum */
case t_character:
return ECL_CODE_CHAR('\0'); /* Immediate character */
default:;
}
ecl_disable_interrupts();
tm = tm_of(t);
ONCE_MORE:
obj = tm->tm_free;
if (obj == OBJNULL) {
cl_index available = available_pages();
if (tm->tm_npage >= tm->tm_maxpage)
goto CALL_GC;
if (available < 1) {
ignore_maximum_pages = FALSE;
goto CALL_GC;
}
p = alloc_page(1);
add_page_to_freelist(p, tm);
obj = tm->tm_free;
/* why this? Beppe
if (tm->tm_npage >= tm->tm_maxpage)
goto CALL_GC; */
}
tm->tm_free = ((struct freelist *)obj)->f_link;
--(tm->tm_nfree);
(tm->tm_nused)++;
obj->d.t = (short)t;
obj->d.m = FALSE;
/* Now initialize the object so that it can be correctly marked
* by the GC
*/
switch (t) {
case t_bignum:
ECL_BIGNUM_DIM(obj) = ECL_BIGNUM_SIZE(obj) = 0;
ECL_BIGNUM_LIMBS(obj) = NULL;
break;
case t_ratio:
obj->ratio.num = OBJNULL;
obj->ratio.den = OBJNULL;
break;
#ifdef ECL_SSE2
case t_sse_pack:
#endif
case t_singlefloat:
case t_doublefloat:
#ifdef ECL_LONG_FLOAT
case t_longfloat:
#endif
break;
case t_complex:
obj->complex.imag = OBJNULL;
obj->complex.real = OBJNULL;
break;
case t_symbol:
obj->symbol.plist = OBJNULL;
obj->symbol.gfdef = OBJNULL;
obj->symbol.value = OBJNULL;
obj->symbol.name = OBJNULL;
obj->symbol.hpack = OBJNULL;
break;
case t_package:
obj->pack.name = OBJNULL;
obj->pack.nicknames = OBJNULL;
obj->pack.shadowings = OBJNULL;
obj->pack.uses = OBJNULL;
obj->pack.usedby = OBJNULL;
obj->pack.internal = OBJNULL;
obj->pack.external = OBJNULL;
break;
case t_cons:
#error "FIXME"
obj->cons.car = OBJNULL;
obj->cons.cdr = OBJNULL;
break;
case t_hashtable:
obj->hash.rehash_size = OBJNULL;
obj->hash.threshold = OBJNULL;
obj->hash.data = NULL;
break;
case t_array:
obj->array.dims = NULL;
obj->array.displaced = ECL_NIL;
obj->array.elttype = (short)ecl_aet_object;
obj->array.self.t = NULL;
break;
#ifdef ECL_UNICODE
case t_string:
#endif
case t_vector:
obj->array.displaced = ECL_NIL;
obj->array.elttype = (short)ecl_aet_object;
obj->array.self.t = NULL;
break;
case t_base_string:
obj->base_string.displaced = ECL_NIL;
obj->base_string.self = NULL;
break;
case t_bitvector:
obj->vector.displaced = ECL_NIL;
obj->vector.self.bit = NULL;
break;
case t_stream:
obj->stream.mode = (short)ecl_smm_broadcast;
obj->stream.file.descriptor = -1;
obj->stream.object0 = OBJNULL;
obj->stream.object1 = OBJNULL;
obj->stream.buffer = NULL;
break;
case t_random:
break;
case t_readtable:
obj->readtable.table = NULL;
break;
case t_pathname:
obj->pathname.host = OBJNULL;
obj->pathname.device = OBJNULL;
obj->pathname.directory = OBJNULL;
obj->pathname.name = OBJNULL;
obj->pathname.type = OBJNULL;
obj->pathname.version = OBJNULL;
break;
case t_bytecodes:
obj->bytecodes.lex = ECL_NIL;
obj->bytecodes.name = ECL_NIL;
obj->bytecodes.definition = ECL_NIL;
obj->bytecodes.specials = ECL_NIL;
obj->bytecodes.code_size = 0;
obj->bytecodes.code = NULL;
obj->bytecodes.data = NULL;
break;
case t_bclosure:
obj->bclosure.code =
obj->bclosure.lex = ECL_NIL;
break;
case t_cfun:
case t_cfunfixed:
obj->cfun.name = OBJNULL;
obj->cfun.block = NULL;
break;
case t_cclosure:
obj->cclosure.env = OBJNULL;
obj->cclosure.block = NULL;
break;
/*
case t_spice:
break;
*/
#ifdef ECL_THREADS
case t_process:
obj->process.name = OBJNULL;
obj->process.function = OBJNULL;
obj->process.args = OBJNULL;
obj->process.env = NULL;
obj->process.interrupt = OBJNULL;
break;
case t_lock:
obj->lock.mutex = OBJNULL;
case t_condition_variable:
obj->condition_variable.cv = OBJNULL;
break;
#endif
#ifdef ECL_SEMAPHORES
case t_semaphore:
obj->semaphore.handle = NULL;
break;
#endif
case t_instance:
obj->instance.length = 0;
ECL_CLASS_OF(obj) = OBJNULL;
obj->instance.sig = ECL_NIL;
obj->instance.isgf = 0;
obj->instance.slots = NULL;
break;
case t_codeblock:
obj->cblock.locked = 0;
obj->cblock.name = ECL_NIL;
obj->cblock.handle = NULL;
obj->cblock.entry = NULL;
obj->cblock.data = NULL;
obj->cblock.data_size = 0;
obj->cblock.data_text = NULL;
obj->cblock.data_text_size = 0;
obj->cblock.links = ECL_NIL;
obj->cblock.next = ECL_NIL;
break;
case t_foreign:
obj->foreign.tag = ECL_NIL;
obj->foreign.size = 0;
obj->foreign.data = NULL;
break;
default:
printf("\ttype = %d\n", t);
ecl_internal_error("alloc botch.");
}
ecl_enable_interrupts();
return(obj);
CALL_GC:
ecl_gc(tm->tm_type);
if (tm->tm_nfree != 0 &&
(float)tm->tm_nfree * 10.0 >= (float)tm->tm_nused)
goto ONCE_MORE;
/* EXHAUSTED: */
if (ignore_maximum_pages) {
if (tm->tm_maxpage/2 <= 0)
tm->tm_maxpage += 1;
else
tm->tm_maxpage += tm->tm_maxpage/2;
goto ONCE_MORE;
}
GC_disable();
{ cl_object s = ecl_make_simple_base_string(tm_table[(int)t].tm_name+1, -1);
GC_enable();
CEerror(ECL_T, "The storage for ~A is exhausted.~%\
Currently, ~D pages are allocated.~%\
Use ALLOCATE to expand the space.",
2, s, MAKE_FIXNUM(tm->tm_npage));
}
goto ONCE_MORE;
}
cl_object
ecl_cons(cl_object a, cl_object d)
{
register cl_object obj;
register cl_ptr p;
struct typemanager *tm=(&tm_table[(int)t_cons]);
ecl_disable_interrupts();
ONCE_MORE:
obj = tm->tm_free;
if (obj == OBJNULL) {
if (tm->tm_npage >= tm->tm_maxpage)
goto CALL_GC;
if (available_pages() < 1) {
ignore_maximum_pages = FALSE;
goto CALL_GC;
}
p = alloc_page(1);
add_page_to_freelist(p,tm);
obj = tm->tm_free;
if (tm->tm_npage >= tm->tm_maxpage)
goto CALL_GC;
}
tm->tm_free = ((struct freelist *)obj)->f_link;
--(tm->tm_nfree);
(tm->tm_nused)++;
obj->d.t = (short)t_cons;
obj->d.m = FALSE;
obj->cons.car = a;
obj->cons.cdr = d;
ecl_enable_interrupts();
return(obj);
CALL_GC:
ecl_gc(t_cons);
if ((tm->tm_nfree != 0) && (tm->tm_nfree * 10.0 >= tm->tm_nused))
goto ONCE_MORE;
/* EXHAUSTED: */
if (ignore_maximum_pages) {
if (tm->tm_maxpage/2 <= 0)
tm->tm_maxpage += 1;
else
tm->tm_maxpage += tm->tm_maxpage/2;
goto ONCE_MORE;
}
CEerror(ECL_T, "The storage for CONS is exhausted.~%\
Currently, ~D pages are allocated.~%\
Use ALLOCATE to expand the space.",
1, MAKE_FIXNUM(tm->tm_npage));
goto ONCE_MORE;
#undef tm
}
cl_object
ecl_alloc_instance(cl_index slots)
{
cl_object i = ecl_alloc_object(t_instance);
if (slots >= ECL_SLOTS_LIMIT)
FEerror("Limit on instance size exceeded: ~S slots requested.",
1, MAKE_FIXNUM(slots));
/* INV: slots > 0 */
i->instance.slots = (cl_object*)ecl_alloc(sizeof(cl_object) * slots);
i->instance.length = slots;
return i;
}
void *
ecl_alloc(cl_index n)
{
volatile cl_ptr p;
struct contblock **cbpp;
cl_index i, m;
bool g;
g = FALSE;
n = round_up(n);
ecl_disable_interrupts();
ONCE_MORE:
/* Use extra indirection so that cb_pointer can be updated */
for (cbpp = &cb_pointer; (*cbpp) != NULL; cbpp = &(*cbpp)->cb_link)
if ((*cbpp)->cb_size >= n) {
p = (cl_ptr)(*cbpp);
i = (*cbpp)->cb_size - n;
*cbpp = (*cbpp)->cb_link;
--ncb;
cl_dealloc(p+n, i);
ecl_enable_interrupts();
return(p);
}
m = round_to_page(n);
if (ncbpage + m > maxcbpage || available_pages() < m) {
if (available_pages() < m)
ignore_maximum_pages = FALSE;
if (!g) {
ecl_gc(t_contiguous);
g = TRUE;
goto ONCE_MORE;
}
if (ignore_maximum_pages) {
if (maxcbpage/2 <= 0)
maxcbpage += 1;
else
maxcbpage += maxcbpage/2;
g = FALSE;
goto ONCE_MORE;
}
CEerror(ECL_T, "Contiguous blocks exhausted.~%\
Currently, ~D pages are allocated.~%\
Use ALLOCATE-CONTIGUOUS-PAGES to expand the space.",
1, MAKE_FIXNUM(ncbpage));
g = FALSE;
goto ONCE_MORE;
}
p = alloc_page(m);
for (i = 0; i < m; i++)
type_map[page(p) + i] = (char)t_contiguous;
ncbpage += m;
cl_dealloc(p+n, LISP_PAGESIZE*m - n);
ecl_enable_interrupts();
return memset(p, 0, n);
}
/*
* adds a contblock to the list of available ones, pointed by cb_pointer,
* sorted by increasing size.
*/
void
cl_dealloc(void *p, cl_index s)
{
struct contblock **cbpp, *cbp;
if (s < CBMINSIZE)
return;
ncb++;
cbp = (struct contblock *)p;
cbp->cb_size = s;
for (cbpp = &cb_pointer; *cbpp != NULL; cbpp = &((*cbpp)->cb_link))
if ((*cbpp)->cb_size >= s) {
cbp->cb_link = *cbpp;
*cbpp = cbp;
return;
}
cbp->cb_link = NULL;
*cbpp = cbp;
}
/*
* align must be a power of 2 representing the alignment boundary
* required for the block.
*/
void *
ecl_alloc_align(cl_index size, cl_index align)
{
void *output;
ecl_disable_interrupts();
align--;
if (align)
output = (void*)(((cl_index)ecl_alloc(size + align) + align - 1) & ~align);
else
output = ecl_alloc(size);
ecl_enable_interrupts();
return output;
}
static void
init_tm(cl_type t, const char *name, cl_index elsize, cl_index maxpage)
{
int i, j;
struct typemanager *tm = &tm_table[(int)t];
if (elsize < 2*sizeof(cl_index)) {
// A free list cell does not fit into this type
elsize = 2*sizeof(cl_index);
}
tm->tm_name = name;
for (i = (int)t_start, j = i-1; i < (int)t_end; i++)
if (tm_table[i].tm_size >= elsize &&
(j < (int)t_start || tm_table[j].tm_size > tm_table[i].tm_size))
j = i;
if (j >= (int)t_start) {
tm->tm_type = (cl_type)j;
tm_table[j].tm_maxpage += maxpage;
return;
}
tm->tm_type = t;
tm->tm_size = round_up(elsize);
tm->tm_nppage = LISP_PAGESIZE/round_up(elsize);
tm->tm_free = OBJNULL;
tm->tm_nfree = 0;
tm->tm_nused = 0;
tm->tm_npage = 0;
tm->tm_maxpage = maxpage;
tm->tm_gccount = 0;
}
static int alloc_initialized = FALSE;
void
init_alloc(void)
{
cl_index i;
if (alloc_initialized) return;
alloc_initialized = TRUE;
holepage = 0;
new_holepage = HOLEPAGE;
#ifdef USE_MMAP
real_maxpage = MAXPAGE;
#elif defined(__CYGWIN__)
real_maxpage = MAXPAGE;
#elif !defined(HAVE_ULIMIT_H)
{
struct rlimit data_rlimit;
# ifdef __MACH__
sbrk(0);
getrlimit(RLIMIT_DATA, &data_rlimit);
real_maxpage = ((unsigned)get_etext() +
(unsigned)data_rlimit.rlim_cur)/LISP_PAGESIZE;
# else
extern etext;
getrlimit(RLIMIT_DATA, &data_rlimit);
real_maxpage = ((unsigned int)&etext +
(unsigned)data_rlimit.rlim_cur)/LISP_PAGESIZE;
# endif
if (real_maxpage > MAXPAGE) real_maxpage = MAXPAGE;
}
#else /* HAVE_ULIMIT */
real_maxpage= ulimit(UL_GMEMLIM)/LISP_PAGESIZE;
if (real_maxpage > MAXPAGE) real_maxpage = MAXPAGE;
#endif /* USE_MMAP or HAVE_ULIMIT */
#ifdef USE_MMAP
heap_start = NULL;
#else
heap_end = sbrk(0);
i = ((cl_index)heap_end) % LISP_PAGESIZE;
if (i)
sbrk(LISP_PAGESIZE - i);
heap_end = heap_start = data_end = sbrk(0);
#endif
cl_resize_hole(INIT_HOLEPAGE);
for (i = 0; i < MAXPAGE; i++)
type_map[i] = (char)t_other;
/* Initialization must be done in increasing size order: */
init_tm(t_singlefloat, "FSINGLE-FLOAT", /* 8 */
sizeof(struct ecl_singlefloat), 1);
init_tm(t_cons, ".CONS", sizeof(struct ecl_cons), 384); /* 12 */
init_tm(t_doublefloat, "LDOUBLE-FLOAT", /* 16 */
sizeof(struct ecl_doublefloat), 1);
init_tm(t_bytecodes, "bBYTECODES", sizeof(struct ecl_bytecodes), 64);
init_tm(t_bytecodes, "bBCLOSURE", sizeof(struct ecl_bclosure), 64);
init_tm(t_base_string, "\"BASE-STRING", sizeof(struct ecl_base_string), 64); /* 20 */
#ifdef ECL_UNICODE
init_tm(t_string, "\"STRING", sizeof(struct ecl_string), 64);
#endif
init_tm(t_array, "aARRAY", sizeof(struct ecl_array), 64); /* 24 */
init_tm(t_pathname, "pPATHNAME", sizeof(struct ecl_pathname), 1); /* 28 */
init_tm(t_symbol, "|SYMBOL", sizeof(struct ecl_symbol), 64); /* 32 */
init_tm(t_package, ":PACKAGE", sizeof(struct ecl_package), 1); /* 36 */
init_tm(t_codeblock, "#CODEBLOCK", sizeof(struct ecl_codeblock), 1);
init_tm(t_bignum, "BBIGNUM", sizeof(struct ecl_bignum), 16);
init_tm(t_ratio, "RRATIO", sizeof(struct ecl_ratio), 1);
init_tm(t_complex, "CCOMPLEX", sizeof(struct ecl_complex), 1);
init_tm(t_hashtable, "hHASH-TABLE", sizeof(struct ecl_hashtable), 1);
init_tm(t_vector, "vVECTOR", sizeof(struct ecl_vector), 2);
init_tm(t_bitvector, "bBIT-VECTOR", sizeof(struct ecl_vector), 1);
init_tm(t_stream, "sSTREAM", sizeof(struct ecl_stream), 1);
init_tm(t_random, "$RANDOM-STATE", sizeof(struct ecl_random), 1);
init_tm(t_readtable, "rREADTABLE", sizeof(struct ecl_readtable), 1);
init_tm(t_cfun, "fCFUN", sizeof(struct ecl_cfun), 32);
init_tm(t_cfunfixed, "fCFUN", sizeof(struct ecl_cfun), 32);
init_tm(t_cclosure, "cCCLOSURE", sizeof(struct ecl_cclosure), 1);
init_tm(t_instance, "IINSTANCE", sizeof(struct ecl_instance), 32);
init_tm(t_foreign, "LFOREIGN", sizeof(struct ecl_foreign), 1);
#ifdef ECL_THREADS
init_tm(t_process, "tPROCESS", sizeof(struct ecl_process), 2);
init_tm(t_lock, "tLOCK", sizeof(struct ecl_lock), 2);
init_tm(t_condition_variable, "tCONDITION-VARIABLE",
sizeof(struct ecl_condition_variable), 2);
#endif /* THREADS */
#ifdef ECL_SEMAPHORES
init_tm(t_semaphore, "tSEMAPHORE",
sizeof(struct ecl_semaphore), 2);
#endif
#ifdef ECL_LONG_FLOAT
init_tm(t_longfloat, "tLONGFLOAT", sizeof(struct ecl_long_float), 2);
#endif
ncb = 0;
ncbpage = 0;
maxcbpage = 2048;
#ifdef NEED_MALLOC
malloc_list = ECL_NIL;
ecl_register_static_root(&malloc_list);
#endif
}
static int
t_from_type(cl_object type)
{ int t;
type = cl_string(type);
for (t = (int)t_start ; t < (int)t_end ; t++) {
struct typemanager *tm = &tm_table[t];
if (tm->tm_name &&
strncmp((tm->tm_name)+1, type->base_string.self, type->base_string.fillp) == 0)
return(t);
}
FEerror("Unrecognized type", 0);
}
@(defun si::allocate (type qty &optional (now ECL_NIL))
struct typemanager *tm;
cl_ptr pp;
cl_index i;
@
tm = tm_of(t_from_type(type));
i = ecl_to_size(qty);
if (tm->tm_npage > i) i = tm->tm_npage;
tm->tm_maxpage = i;
if (now == ECL_NIL || tm->tm_maxpage <= tm->tm_npage)
@(return ECL_T)
if (available_pages() < tm->tm_maxpage - tm->tm_npage ||
(pp = alloc_page(tm->tm_maxpage - tm->tm_npage)) == NULL)
FEerror("Can't allocate ~D pages for ~A.", 2, type,
make_constant_base_string(tm->tm_name+1));
for (; tm->tm_npage < tm->tm_maxpage; pp += LISP_PAGESIZE)
add_page_to_freelist(pp, tm);
@(return ECL_T)
@)
@(defun si::maximum-allocatable-pages (type)
@
@(return MAKE_FIXNUM(tm_of(t_from_type(type))->tm_maxpage))
@)
@(defun si::allocated-pages (type)
@
@(return MAKE_FIXNUM(tm_of(t_from_type(type))->tm_npage))
@)
@(defun si::allocate-contiguous-pages (qty &optional (now ECL_NIL))
cl_index i, m;
cl_ptr p;
@
i = ecl_to_size(qty);
if (ncbpage > i)
FEerror("Can't set the limit for contiguous blocks to ~D,~%\
since ~D pages are already allocated.",
2, qty, MAKE_FIXNUM(ncbpage));
maxcbpage = i;
if (Null(now))
@(return ECL_T)
m = maxcbpage - ncbpage;
if (available_pages() < m || (p = alloc_page(m)) == NULL)
FEerror("Can't allocate ~D pages for contiguous blocks.",
1, qty);
for (i = 0; i < m; i++)
type_map[page(p + LISP_PAGESIZE*i)] = (char)t_contiguous;
ncbpage += m;
cl_dealloc(p, LISP_PAGESIZE*m);
@(return ECL_T)
@)
@(defun si::allocated-contiguous-pages ()
@
@(return MAKE_FIXNUM(ncbpage))
@)
@(defun si::maximum-contiguous-pages ()
@
@(return MAKE_FIXNUM(maxcbpage))
@)
@(defun si::get-hole-size ()
@
@(return MAKE_FIXNUM(new_holepage))
@)
@(defun si::set-hole-size (size)
cl_index i;
@
i = ecl_to_size(size);
if (i == 0 || i > available_pages() + new_holepage)
FEerror("Illegal value for the hole size.", 0);
new_holepage = i;
@(return size)
@)
@(defun si::ignore-maximum-pages (&optional (flag OBJNULL))
@
if (flag == OBJNULL)
@(return (ignore_maximum_pages? ECL_T : ECL_NIL))
ignore_maximum_pages = Null(flag);
@(return flag)
@)
#ifdef NEED_MALLOC
/*
UNIX malloc simulator.
Used by
getwd, popen, etc.
*/
#undef malloc
#undef calloc
#undef free
#undef cfree
#undef realloc
void *
malloc(size_t size)
{
cl_object x;
if (!GC_enabled() && !alloc_initialized)
init_alloc();
x = alloc_simple_base_string(size-1);
x->base_string.self = (char *)ecl_alloc(size);
malloc_list = ecl_cons(x, malloc_list);
return(x->base_string.self);
}
void
free(void *ptr)
{
cl_object *p;
if (ptr) {
for (p = &malloc_list; !ecl_endp(*p); p = &(CDR((*p))))
if ((CAR((*p)))->base_string.self == ptr) {
cl_dealloc(CAR((*p))->base_string.self, CAR((*p))->base_string.dim+1);
CAR((*p))->base_string.self = NULL;
*p = CDR((*p));
return;
}
FEerror("free(3) error.", 0);
}
}
void *
realloc(void *ptr, size_t size)
{
cl_object x;
size_t i, j;
if (ptr == NULL)
return malloc(size);
for (x = malloc_list; !ecl_endp(x); x = CDR(x))
if (CAR(x)->base_string.self == ptr) {
x = CAR(x);
if (x->base_string.dim >= size) {
x->base_string.fillp = size;
return(ptr);
} else {
j = x->base_string.dim;
x->base_string.self = (char *)ecl_alloc(size);
x->base_string.fillp = x->base_string.dim = size;
memcpy(x->base_string.self, ptr, j);
cl_dealloc(ptr, j);
return(x->base_string.self);
}
}
FEerror("realloc(3) error.", 0);
}
void *
calloc(size_t nelem, size_t elsize)
{
char *ptr;
size_t i = nelem*elsize;
ptr = malloc(i);
memset(ptr, 0 , i);
return(ptr);
}
void cfree(void *ptr)
{
free(ptr);
}
/* make f allocate enough extra, so that we can round
up, the address given to an even multiple. Special
case of size == 0 , in which case we just want an aligned
number in the address range
*/
#define ALLOC_ALIGNED(f, size, align) \
((align) <= 4 ? (int)(f)(size) : \
((align) * (((unsigned)(f)(size + (size ? (align) - 1 : 0)) + (align) - 1)/(align))))
void *
memalign(size_t align, size_t size)
{ cl_object x = alloc_simple_base_string(size);
malloc_list = ecl_cons(x, malloc_list);
return x->base_string.self;
}
# ifdef WANT_VALLOC
char *
valloc(size_t size)
{ return memalign(getpagesize(), size);}
# endif /* WANT_VALLOC */
#endif /* NEED_MALLOC */

986
src/c/gbc-new.d
View file

@ -1,986 +0,0 @@
/* -*- Mode: C; c-basic-offset: 8; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=8 shiftwidth=4 expandtab: */
/*
gbc.c -- Garbage collector.
*/
/*
Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
Copyright (c) 1990, Giuseppe Attardi and William F. Schelter.
Copyright (c) 2001, Juan Jose Garcia Ripoll.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../Copyright' for full details.
*/
#include "ecl.h"
#include "page.h"
/******************************* EXPORTS ******************************/
bool GC_enable;
int gc_time; /* Beppe */
/******************************* ------- ******************************/
/*
mark_table[m]:i represents word w = 128*m + 4*i, where m = addr-DATA_START.
Therefore m = w >> 7, i = (w / 4) % 32 = (w >> 2) & 0x1f.
*/
static int *mark_table;
static void inline
set_mark_bit(void *x) {
int w = (int)x;
int m = (w - DATA_START) >> 7;
int i = (w >> 2) & 0x1f;
mark_table[m] |= (1 << i);
}
static int inline
get_mark_bit(void *x) {
int w = (int)x;
int m = (w - DATA_START) >> 7;
int i = (w >> 2) & 0x1f;
return (mark_table[m] >> i) & 1;
}
#define inheap(pp) ((unsigned long)(pp) < (unsigned long)heap_end)
#define VALID_DATA_ADDRESS(pp) \
!ECL_IMMEDIATE(pp) && (cl_index)DATA_START <= (cl_index)(pp) && (cl_index)(pp) < (cl_index)heap_end
cl_object siVgc_verbose;
cl_object siVgc_message;
static bool debug = FALSE;
static int maxpage;
#define GC_ROOT_MAX 200
static cl_object *gc_root[GC_ROOT_MAX];
static int gc_roots;
static bool collect_blocks;
/*
We must register location, since value may be reassigned (e.g. malloc_list)
*/
static void _mark_object (cl_object x);
static void _mark_contblock (void *p, size_t s);
extern void sigint (void);
void
register_root(cl_object *p)
{
if (gc_roots >= GC_ROOT_MAX)
error("too many roots");
gc_root[gc_roots++] = p;
}
@(defun gc (area)
@
if (!GC_enabled())
error("GC is not enabled");
if (Null(area))
gc(t_cons);
else
gc(t_contiguous);
@(return)
@)
/*----------------------------------------------------------------------
* Mark phase
*----------------------------------------------------------------------
*/
/* Whenever two arrays are linked together by displacement,
if one is live, the other will be made live */
#define mark_displaced(ar) mark_object(ar)
#define mark_contblock(x,s) {if (collect_blocks) _mark_contblock(x,s); }
#if 1
#define mark_object(x) if ((x != OBJNULL) && !ECL_IMMEDIATE(x)) _mark_object(x)
#define mark_next(a) if ((a != OBJNULL) && !ECL_IMMEDIATE(a)) { x=(a); goto BEGIN; }
#else
#define mark_object(x) _mark_object(x)
#define mark_next(a) x=(a); goto BEGIN
#endif
/* We make bitvectors multiple of sizeof(int) in size allocated
Assume 8 = number of bits in char */
#define W_SIZE (8*sizeof(int))
static void
_mark_object(cl_object x)
{
size_t i, j;
cl_object *p, y;
char *cp;
cs_check(x);
BEGIN:
#if 0
/* We cannot get here because mark_object() and mark_next() already check this */
if (ECL_IMMEDIATE(x)) return; /* fixnum, character or locative */
if (x == OBJNULL)
return;
#endif
if (get_mark_bit(x))
return;
set_mark_bit(x);
switch (ecl_t_of(x)) {
case t_bignum:
#ifdef WITH_GMP
if (collect_blocks) {
/* GMP may set num.alloc before actually allocating anything.
With these checks we make sure we do not move anything
we don't have to. Besides, we use big_dim as the size
of the object, because big_size might even be smaller.
*/
char *limbs = (char *)x->big.big_limbs;
size_t size = x->big.big_dim * sizeof(mp_limb_t);
if (size) mark_contblock(limbs, size);
}
#endif /* WITH_GMP */
break;
case t_ratio:
mark_object(x->ratio.num);
mark_next(x->ratio.den);
break;
#ifdef ECL_SSE2
case t_sse_pack:
#endif
case t_singlefloat:
case t_doublefloat:
break;
case t_complex:
mark_object(x->complex.imag);
mark_next(x->complex.real);
break;
case t_character:
break;
case t_symbol:
mark_object(x->symbol.name);
mark_object(x->symbol.plist);
mark_object(ECL_SYM_FUN(x));
mark_next(SYM_VAL(x));
break;
case t_package:
mark_object(x->pack.name);
mark_object(x->pack.nicknames);
mark_object(x->pack.shadowings);
mark_object(x->pack.uses);
mark_object(x->pack.usedby);
mark_object(x->pack.internal);
mark_next(x->pack.external);
break;
case t_cons:
mark_object(CAR(x));
mark_next(CDR(x));
break;
case t_hashtable:
mark_object(x->hash.rehash_size);
mark_object(x->hash.threshold);
if (x->hash.data == NULL)
break;
for (i = 0, j = x->hash.size; i < j; i++) {
mark_object(x->hash.data[i].key);
mark_object(x->hash.data[i].value);
}
mark_contblock(x->hash.data, j * sizeof(struct hashtable_entry));
break;
case t_array:
mark_contblock(x->array.dims, sizeof(x->array.dims[0])*x->array.rank);
#ifdef ECL_UNICODE
case t_string:
#endif
case t_vector:
if ((y = x->array.displaced) != ECL_NIL)
mark_displaced(y);
cp = (char *)x->array.self.t;
if (cp == NULL)
break;
switch ((enum aelttype)x->array.elttype) {
#ifdef ECL_UNICODE
case ecl_aet_ch:
#endif
case ecl_aet_object:
if (x->array.displaced == ECL_NIL || CAR(x->array.displaced) == ECL_NIL) {
cl_object *p = x->array.self.t;
cl_index i;
if (x->array.t == t_vector && x->vector.hasfillp)
i = x->vector.fillp;
else
i = x->vector.dim;
while (i-- > 0)
mark_object(p[i]);
}
j = sizeof(cl_object)*x->array.dim;
break;
case ecl_aet_bc:
j = x->array.dim;
break;
case ecl_aet_bit:
j = sizeof(int) * ((x->vector.offset + x->vector.dim + W_SIZE -1)/W_SIZE);
break;
case ecl_aet_fix:
j = x->array.dim * sizeof(cl_fixnum);
break;
case ecl_aet_sf:
j = x->array.dim * sizeof(float);
break;
case ecl_aet_df:
j = x->array.dim * sizeof(double);
break;
default:
error("Allocation botch: unknown array element type");
}
goto COPY_ARRAY;
case t_base_string:
if ((y = x->base_string.displaced) != ECL_NIL)
mark_displaced(y);
cp = x->base_string.self;
if (cp == NULL)
break;
j = x->base_string.dim;
COPY_ARRAY:
mark_contblock(cp, j);
break;
case t_bitvector:
if ((y = x->vector.displaced) != ECL_NIL)
mark_displaced(y);
cp = x->vector.self.bit;
if (cp == NULL)
break;
j= sizeof(int) * ((x->vector.offset + x->vector.dim + W_SIZE -1)/W_SIZE);
goto COPY_ARRAY;
case t_stream:
switch ((enum smmode)x->stream.mode) {
case ecl_smm_closed:
/* Rest of fields are NULL */
mark_next(x->stream.object1);
break;
case ecl_smm_input:
case ecl_smm_output:
case ecl_smm_io:
case ecl_smm_probe:
mark_object(x->stream.object0);
mark_object(x->stream.object1);
mark_contblock(x->stream.buffer, BUFSIZ);
break;
case ecl_smm_synonym:
mark_next(x->stream.object0);
break;
case ecl_smm_broadcast:
case ecl_smm_concatenated:
mark_next(x->stream.object0);
break;
case ecl_smm_two_way:
case ecl_smm_echo:
mark_object(x->stream.object0);
mark_next(x->stream.object1);
break;
case ecl_smm_string_input:
case ecl_smm_string_output:
mark_next(x->stream.object0);
break;
default:
error("mark stream botch");
}
break;
case t_random:
break;
case t_readtable:
if (x->readtable.table == NULL)
break;
mark_contblock((char *)(x->readtable.table), RTABSIZE*sizeof(struct readtable_entry));
for (i = 0; i < RTABSIZE; i++) {
cl_object *p = x->readtable.table[i].dispatch_table;
mark_object(x->readtable.table[i].macro);
if (p != NULL) {
mark_contblock(p, RTABSIZE*sizeof(cl_object));
for (j = 0; j < RTABSIZE; j++)
mark_object(p[j]);
}
}
break;
case t_pathname:
mark_object(x->pathname.host);
mark_object(x->pathname.device);
mark_object(x->pathname.directory);
mark_object(x->pathname.name);
mark_object(x->pathname.type);
mark_object(x->pathname.version);
break;
case t_bytecodes: {
cl_index i, size;
size = x->bytecodes.size;
mark_object(x->bytecodes.lex);
mark_contblock(x->bytecodes.data, size * sizeof(cl_object));
for (i=0; i<size; i++)
mark_object(x->bytecodes.data[i]);
break;
}
case t_cfun:
mark_object(x->cfun.block);
mark_object(x->cfun.name);
break;
case t_cclosure:
mark_object(x->cfun.block);
mark_object(x->cclosure.env);
break;
#ifdef THREADS
case t_cont:
mark_next(x->cn.cn_thread);
break;
case t_thread:
/* Already marked by malloc
mark_contblock(x->thread.data, x->thread.size);
*/
mark_next(x->thread.entry);
break;
#endif THREADS
case t_instance:
mark_object(x->instance.class);
p = x->instance.slots;
if (p == NULL)
break;
for (i = 0, j = x->instance.length; i < j; i++)
mark_object(p[i]);
mark_contblock(p, j*sizeof(cl_object));
break;
case t_gfun:
mark_object(x->gfun.name);
mark_object(x->gfun.method_hash);
mark_object(x->gfun.instance);
p = x->gfun.specializers;
if (p == NULL)
break;
for (i = 0, j = x->gfun.arg_no; i < j; i++)
mark_object(p[i]);
mark_contblock(p, j*sizeof(cl_object));
break;
case t_codeblock:
mark_object(x->cblock.name);
mark_contblock(x->cblock.start, x->cblock.size);
if (x->cblock.data) {
cl_index i = x->cblock.data_size;
cl_object *p = x->cblock.data;
while (i--)
mark_object(p[i]);
}
break;
default:
if (debug)
printf("\ttype = %d\n", ecl_t_of(x));
error("mark botch");
}
}
static void
mark_stack_conservative(int *top, int *bottom)
{
int p, m;
cl_object x;
struct typemanager *tm;
register int *j;
if (debug) { printf("Traversing C stack .."); fflush(stdout); }
/* On machines which align local pointers on multiple of 2 rather
than 4 we need to mark twice
if (offset) mark_stack_conservative(bottom, ((char *) top) + offset, 0);
*/
for (j = top ; j >= bottom ; j--) {
/* improved Beppe: */
if (VALID_DATA_ADDRESS(*j) && type_map[p = page(*j)] < (char)t_end) {
tm = tm_of((enum type)type_map[p]);
x = (cl_object)(*j - (*j - (int)pagetochar(p)) % tm->tm_size);
if (!get_mark_bit(x))
mark_object(x);
}
}
if (debug) {printf(". done.\n"); fflush(stdout); }
}
static void
mark_phase(void)
{
register int i;
register struct package *pp;
register ecl_bds_ptr bdp;
register ecl_frame_ptr frp;
register ecl_ihs_ptr ihsp;
mark_object(ECL_NIL);
mark_object(ECL_T);
#ifdef THREADS
{
pd *pdp;
lpd *old_clwp = clwp;
for (pdp = running_head; pdp != (pd *)NULL; pdp = pdp->pd_next) {
clwp = pdp->pd_lpd;
#endif THREADS
for (i=0; i<NValues; i++)
mark_object(VALUES(i));
for (bdp = bds_org; bdp <= bds_top; bdp++) {
mark_object(bdp->bds_sym);
mark_object(bdp->bds_val);
}
for (frp = frs_org; frp <= frs_top; frp++) {
mark_object(frp->frs_val);
mark_object(frp->frs_lex);
}
for (ihsp = ihs_org; ihsp <= ihs_top; ihsp++) {
mark_object(ihsp->ihs_function);
mark_object(ihsp->ihs_base);
}
mark_object(lex_env);
#ifdef THREADS
/* added to mark newly allocated objects */
mark_object(clwp->lwp_alloc_temporary);
mark_object(clwp->lwp_fmt_temporary_stream);
mark_object(clwp->lwp_PRINTstream);
mark_object(clwp->lwp_PRINTcase);
mark_object(clwp->lwp_READtable);
mark_object(clwp->lwp_delimiting_char);
mark_object(clwp->lwp_token);
/* (current-thread) can return it at any time
*/
mark_object(clwp->lwp_thread);
#endif THREADS
/* now collect from the c-stack of the thread ... */
{ int *where;
volatile jmp_buf buf;
/* ensure flushing of register caches */
if (ecl_setjmp(buf) == 0) ecl_longjmp(buf, 1);
#ifdef THREADS
if (clwp != old_clwp) /* is not the executing stack */
# ifdef __linux
where = (int *)pdp->pd_env[0].__jmpbuf[0].__sp;
# else
where = (int *)pdp->pd_env[JB_SP];
# endif
else
#endif THREADS
where = (int *)&where ;
/* If the locals of type object in a C function could be
aligned other than on multiples of sizeof (char *)
we would have to mark twice */
if (where > cs_org)
mark_stack_conservative(where, cs_org);
else
mark_stack_conservative(cs_org, where);
}
#ifdef THREADS
}
clwp = old_clwp;
}
#endif THREADS
/* mark roots */
for (i = 0; i < gc_roots; i++)
mark_object(*gc_root[i]);
/* mark registered symbols & keywords */
{
const struct keyword_info *k;
const struct symbol_info *s;
for (k = all_keywords; k->loc != NULL; k++)
mark_object(*(k->loc));
for (s = all_symbols; s->loc != NULL; s++)
mark_object(*(s->loc));
}
if (debug) {
printf("symbol navigation\n");
fflush(stdout);
}
}
static void
sweep_phase(void)
{
register int i, j, k;
register cl_object x;
register char *p;
register struct typemanager *tm;
register cl_object f;
ECL_NIL->symbol.m = FALSE;
ECL_T->symbol.m = FALSE;
if (debug)
printf("type map\n");
for (i = 0; i < maxpage; i++) {
if (type_map[i] == (int)t_contiguous) {
if (debug) {
printf("-");
continue;
}
}
if (type_map[i] >= (int)t_end)
continue;
tm = tm_of((enum type)type_map[i]);
/*
general sweeper
*/
if (debug)
printf("%c", tm->tm_name[0]);
p = pagetochar(i);
f = tm->tm_free;
k = 0;
for (j = tm->tm_nppage; j > 0; --j, p += tm->tm_size) {
x = (cl_object)p;
if (!get_mark_bit(x)) {
((struct freelist *)x)->f_link = f;
f = x;
k++;
}
}
tm->tm_free = f;
tm->tm_nfree += k;
tm->tm_nused -= k;
}
if (debug) {
putchar('\n');
fflush(stdout);
}
}
static void
contblock_sweep_phase(void)
{
register int i, j;
register char *s, *e, *p, *q;
register struct contblock *cbp;
cb_pointer = NULL;
ncb = 0;
for (i = 0; i < maxpage;) {
if (type_map[i] != (int)t_contiguous) {
i++;
continue;
}
for (j = i+1;
j < maxpage && type_map[j] == (int)t_contiguous;
j++)
;
s = pagetochar(i);
e = pagetochar(j);
for (p = s; p < e;) {
if (get_mark_bit((int *)p)) {
p += 4;
continue;
}
q = p + 4;
while (q < e && !get_mark_bit((int *)q))
q += 4;
dealloc(p, q - p);
p = q + 4;
}
i = j + 1;
}
if (debug) {
for (cbp = cb_pointer; cbp != NULL; cbp = cbp->cb_link)
printf("0x%p %d\n", cbp, cbp->cb_size);
fflush(stdout);
}
}
cl_object (*GC_enter_hook)() = NULL;
cl_object (*GC_exit_hook)() = NULL;
#ifdef THREADS
/*
* We execute the GC routine in the main stack.
* The idea is to switch over the main stack that is stopped in the intha
* and to call the GC from there on garbage_parameter. Then you can switch
* back after.
* In addition the interrupt is disabled.
*/
static int i, j;
static sigjmp_buf old_env;
static int val;
static lpd *old_clwp;
static enum type t;
static bool stack_switched = FALSE;
static enum type garbage_parameter;
void
gc(enum type new_name)
{
int tm;
int gc_start = runtime();
start_critical_section();
t = new_name;
garbage_parameter = new_name;
#else
void
gc(enum type t)
{
int i, j;
int tm;
int gc_start = runtime();
#endif THREADS
if (!GC_enabled())
return;
if (SYM_VAL(siVgc_verbose) != ECL_NIL) {
printf("\n[GC ..");
/* To use this should add entries in tm_table for reloc and contig.
fprintf(stdout, "\n[GC for %d %s pages ..",
tm_of(t)->tm_npage,
tm_table[(int)t].tm_name + 1); */
fflush(stdout);
}
debug = symbol_value(siVgc_message) != ECL_NIL;
#ifdef THREADS
if (clwp != &main_lpd) {
if (debug) {
printf("*STACK SWITCH*\n");
fflush (stdout);
}
stack_switched = TRUE;
val = sigsetjmp(old_env, 1);
if (val == 0) {
/* informations used by the garbage collector need to be updated */
# ifdef __linux
running_head->pd_env[0].__jmpbuf[0].__sp = old_env[0].__jmpbuf[0].__sp;
# else
running_head->pd_env[JB_SP] = old_env[JB_SP];
# endif
old_clwp = clwp;
Values = main_lpd.lwp_Values;
clwp = &main_lpd;
siglongjmp(main_pd.pd_env, 2); /* new line */
}
}
else val = 1;
if (val == 1) {
#endif THREADS
if (GC_enter_hook != NULL)
(*GC_enter_hook)(0);
interrupt_enable = FALSE;
collect_blocks = t > t_end;
if (collect_blocks)
cbgccount++;
else
tm_table[(int)t].tm_gccount++;
if (debug) {
if (collect_blocks)
printf("GC entered for collecting blocks\n");
else
printf("GC entered for collecting %s\n", tm_table[(int)t].tm_name);
fflush(stdout);
}
maxpage = page(heap_end);
if (collect_blocks) {
/*
1 page = 512 word
512 bit = 16 word
*/
int mark_table_size = maxpage * (LISP_PAGESIZE / 32);
extern void resize_hole(size_t);
if (holepage < mark_table_size*sizeof(int)/LISP_PAGESIZE + 1)
new_holepage = mark_table_size*sizeof(int)/LISP_PAGESIZE + 1;
if (new_holepage < HOLEPAGE)
new_holepage = HOLEPAGE;
resize_hole(new_holepage);
mark_table = (int*)heap_end;
for (i = 0; i < mark_table_size; i++)
mark_table[i] = 0;
}
if (debug) {
printf("mark phase\n");
fflush(stdout);
tm = runtime();
}
mark_phase();
if (debug) {
printf("mark ended (%d)\n", runtime() - tm);
printf("sweep phase\n");
fflush(stdout);
tm = runtime();
}
sweep_phase();
if (debug) {
printf("sweep ended (%d)\n", runtime() - tm);
fflush(stdout);
}
if (t == t_contiguous) {
if (debug) {
printf("contblock sweep phase\n");
fflush(stdout);
tm = runtime();
}
contblock_sweep_phase();
if (debug)
printf("contblock sweep ended (%d)\n", runtime() - tm);
}
if (debug) {
for (i = 0, j = 0; i < (int)t_end; i++) {
if (tm_table[i].tm_type == (enum type)i) {
printf("%13s: %8d used %8d free %4d/%d pages\n",
tm_table[i].tm_name,
tm_table[i].tm_nused,
tm_table[i].tm_nfree,
tm_table[i].tm_npage,
tm_table[i].tm_maxpage);
j += tm_table[i].tm_npage;
} else
printf("%13s: linked to %s\n",
tm_table[i].tm_name,
tm_table[(int)tm_table[i].tm_type].tm_name);
}
printf("contblock: %d blocks %d pages\n", ncb, ncbpage);
printf("hole: %d pages\n", holepage);
printf("GC ended\n");
fflush(stdout);
}
interrupt_enable = TRUE;
if (GC_exit_hook != NULL)
(*GC_exit_hook)();
#ifdef THREADS
/*
* Back in the right stack
*/
if (stack_switched) {
if (debug) {
printf("*STACK BACK*\n");
fflush (stdout);
}
stack_switched = FALSE;
end_critical_section(); /* we get here from the GC call in scheduler */
clwp = old_clwp;
Values = clwp->lwp_Values;
siglongjmp(old_env, 2);
}
}
#endif THREADS
gc_time += (gc_start = runtime() - gc_start);
if (SYM_VAL(siVgc_verbose) != ECL_NIL) {
/* Don't use fprintf since on Linux it calls malloc() */
printf(". finished in %.2f\"]", gc_start/60.0);
fflush(stdout);
}
#ifdef unix
if (interrupt_flag) sigint();
#endif unix
#ifdef THREADS
end_critical_section();
#endif THREADS
}
/*
*----------------------------------------------------------------------
*
* mark_contblock --
* sets the mark bit for words from address p to address p+s.
* Both p and p+s are rounded to word boundaries.
*
* Results:
* none.
*
* Side effects:
* mark_table
*
*----------------------------------------------------------------------
*/
static void
_mark_contblock(void *x, size_t s)
{
register char *p = x, *q;
register ptrdiff_t pg = page(p);
if (pg < 0 || (enum type)type_map[pg] != t_contiguous)
return;
#if 1
q = p + s;
p = (char *)((int)p&~3);
q = (char *)(((int)q+3)&~3);
for (; p < q; p+= 4)
set_mark_bit(p);
#elif 0
{
int bit_start = ((int)p - DATA_START) >> 2;
int bit_end = ((int)p + s + 3 - DATA_START) >> 2;
int *w = &mark_table[bit_start >> 5];
int b = bit_start & (32 - 1);
int mask = ~0 << b;
int bits = b + bit_end - bit_start;
while (bits >= 32) {
*w |= mask;
w++;
bits -= 32;
mask = ~0;
}
mask &= ~(~0 << bits);
*w |= mask;
}
#else
{
int bit_start = ((int)p - DATA_START) >> 2;
int bits = ((int)p + s + 3 - DATA_START) >> 2 - bit_start;
int mask = 1 << bit_start & (32 - 1);
int *w = &mark_table[bit_start >> 5];
while (bits) {
*w |= mask;
mask <<= 1;
if (!mask) {
mask = 1;
w++;
}
}
}
#endif
}
/*----------------------------------------------------------------------
* Utilities
*----------------------------------------------------------------------
*/
@(defun si::room-report ()
int i;
cl_object *tl;
@
NValues = 8;
VALUES(0) = ecl_make_fixnum(real_maxpage);
VALUES(1) = ecl_make_fixnum(available_pages());
VALUES(2) = ecl_make_fixnum(ncbpage);
VALUES(3) = ecl_make_fixnum(maxcbpage);
VALUES(4) = ecl_make_fixnum(ncb);
VALUES(5) = ecl_make_fixnum(cbgccount);
VALUES(6) = ecl_make_fixnum(holepage);
VALUES(7) = ECL_NIL;
tl = &VALUES(7);
for (i = 0; i < (int)t_end; i++) {
if (tm_table[i].tm_type == (enum type)i) {
tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_nused), ECL_NIL));
tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_nfree), ECL_NIL));
tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_npage), ECL_NIL));
tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_maxpage), ECL_NIL));
tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_gccount), ECL_NIL));
} else {
tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL));
tl = &CDR(*tl = CONS(ecl_make_fixnum(tm_table[i].tm_type), ECL_NIL));
tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL));
tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL));
tl = &CDR(*tl = CONS(ECL_NIL, ECL_NIL));
}
}
return VALUES(0);
@)
@(defun si::reset-gc-count ()
int i;
@
cbgccount = 0;
for (i = 0; i < (int)t_end; i++)
tm_table[i].tm_gccount = 0;
@(return)
@)
@(defun si::gc-time ()
@
@(return ecl_make_fixnum(gc_time))
@)
void
init_GC(void)
{
register_root(&siVgc_verbose);
register_root(&siVgc_message);
siVgc_verbose = make_si_special("*GC-VERBOSE*", ECL_NIL);
siVgc_message = make_si_special("*GC-MESSAGE*", ECL_NIL);
GC_enable();
gc_time = 0;
}

2
src/util/emacs.el
View file

@ -97,7 +97,6 @@
(concat (subseq (buffer-file-name (current-buffer)) 0 -13) x))
'(
"c/all_symbols.d"
"c/alloc.d"
"c/alloc_2.d"
"c/apply.d"
"c/array.d"
@ -127,7 +126,6 @@
"c/ffi.d"
"c/file.d"
"c/format.d"
"c/gbc-new.d"
"c/gbc.d"
"c/gfun.d"
"c/hash.d"