From 61500316b7ea17d0e42f5ca127f2f9fa3e6596a8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Fri, 11 Mar 2016 13:10:51 +0100 Subject: [PATCH] gbc: remove obsolete (non-functional) GC I would like to bring it back to life in the future, but we have to clean the interfaces first. --- src/c/alloc.d | 978 --------------------------------------------- src/c/gbc-new.d | 986 ---------------------------------------------- src/util/emacs.el | 2 - 3 files changed, 1966 deletions(-) delete mode 100644 src/c/alloc.d delete mode 100644 src/c/gbc-new.d diff --git a/src/c/alloc.d b/src/c/alloc.d deleted file mode 100644 index 19269b4ee..000000000 --- a/src/c/alloc.d +++ /dev/null @@ -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 -#include -#include -#include -#include -#include - -#define USE_MMAP -#if defined(USE_MMAP) -#include -#include -#elif defined(HAVE_ULIMIT_H) -#include -#else -#include -#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 */ diff --git a/src/c/gbc-new.d b/src/c/gbc-new.d deleted file mode 100644 index 58edaa6c5..000000000 --- a/src/c/gbc-new.d +++ /dev/null @@ -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; ibytecodes.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; ibds_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; -} diff --git a/src/util/emacs.el b/src/util/emacs.el index be32888e7..15a8ca08e 100644 --- a/src/util/emacs.el +++ b/src/util/emacs.el @@ -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"