diff --git a/msvc/Makefile b/msvc/Makefile index 7b2f540bade99bd1dc1b3dc8562d5b604472c9c1..e1dc4df566c55fddbd16ee13575e76392f6aa5d6 100755 --- a/msvc/Makefile +++ b/msvc/Makefile @@ -134,7 +134,7 @@ GCFLAGS = nodebug=1 CLIBS = $(CLIBS) DbgHelp.lib !endif -CFLAGS = /EHsc /DGC_DLL /DGC_BUILD /nologo /wd4068 /wd4715 /wd4716 /D_CRT_SECURE_NO_DEPRECATE $(CFLAGS_CONFIG) +CFLAGS = /EHsc /DGC_DLL /DGC_BUILD /nologo /wd4068 /wd4715 /wd4716 /D_CRT_SECURE_NO_DEPRECATE /std:c11 $(CFLAGS_CONFIG) LDFLAGS = /link /incremental:no /nologo $(LDFLAGS_CONFIG) /STACK:$(ECL_DEFAULT_C_STACK_SIZE) diff --git a/msvc/c/Makefile b/msvc/c/Makefile index c9d02ab669876093f90e1de42aa68edb296fdb92..c141a8d6b967d549bf6cf747d2a5647ea033af13 100755 --- a/msvc/c/Makefile +++ b/msvc/c/Makefile @@ -13,7 +13,7 @@ ECL_FPE_CODE=fpe_x86.c !if "$(ECL_THREADS)" != "" ECL_THREADS_FLAG=1 THREADS_OBJ= thread.obj mutex.obj condition_variable.obj rwlock.obj \ - semaphore.obj barrier.obj mailbox.obj atomic.obj + semaphore.obj barrier.obj mailbox.obj !else ECL_THREADS_FLAG=0 THREADS_OBJ= @@ -47,7 +47,7 @@ ECL_USE_DBGHELP_FLAG=0 # Programs used by "make": # CC = cl -CFLAGS = -c $(ECL_CFLAGS) -DECL_BUILD -DECL_API="__declspec(dllexport)" -I./ -I../ -I../ecl -I$(srcdir) -I$(srcdir)/unicode +CFLAGS = -c $(ECL_CFLAGS) /std:c11 -DECL_BUILD -DECL_API="__declspec(dllexport)" -I./ -I../ -I../ecl -I$(srcdir) -I$(srcdir)/unicode SHELL = /bin/sh RM = del @@ -79,20 +79,13 @@ HFILES = ..\ecl\config.h ..\ecl\config-internal.h ..\ecl\atomic_ops.h \ $(HDIR)\cache.h $(HDIR)\stack-resize.h \ $(HDIR)\ecl_atomics.h -OBJS = main.obj symbol.obj package.obj cons.obj list.obj\ - apply.obj eval.obj \ - interpreter.obj compiler.obj disassembler.obj \ - instance.obj gfun.obj cache.obj accessor.obj \ - reference.obj character.obj\ - file.obj read.obj print.obj error.obj string.obj cfun.obj\ - parse_integer.obj parse_number.obj \ - float_to_digits.obj float_to_string.obj \ - integer_to_string.obj write_ugly.obj \ - write_object.obj write_symbol.obj \ - write_array.obj write_list.obj write_code.obj \ - write_sse.obj print_unreadable.obj \ - libraries.obj backtrace.obj mmap.obj cdata.obj \ - cos.obj sin.obj tan.obj atan.obj \ +NUCL_OBJS = boot.obj call.obj jump.obj atomic.obj process.obj memory.obj \ + module.obj stacks.obj + +CLOS_OBJS = instance.obj gfun.obj cache.obj accessor.obj + +NUM_OBJS = number.obj num_pred.obj num_arith.obj num_co.obj \ + num_log.obj num_rand.obj cos.obj sin.obj tan.obj atan.obj \ cosh.obj sinh.obj tanh.obj \ exp.obj expt.obj log.obj \ sqrt.obj abs.obj \ @@ -101,18 +94,34 @@ OBJS = main.obj symbol.obj package.obj cons.obj list.obj\ one_plus.obj one_minus.obj \ plus.obj minus.obj times.obj divide.obj \ number_compare.obj number_equalp.obj minmax.obj \ - floor.obj ceiling.obj round.obj truncate.obj \ - typespec.obj assignment.obj \ - predicate.obj big.obj number.obj\ - num_pred.obj num_arith.obj num_co.obj\ - num_log.obj num_rand.obj array.obj vector_push.obj \ + floor.obj ceiling.obj round.obj truncate.obj + +WRITER_OBJS = print.obj float_to_digits.obj float_to_string.obj \ + integer_to_string.obj write_ugly.obj \ + write_object.obj write_symbol.obj \ + write_array.obj write_list.obj write_code.obj \ + write_sse.obj print_unreadable.obj + +READER_OBJS = read.obj parse_integer.obj parse_number.obj + +FFI_OBJS = ffi.obj libraries.obj backtrace.obj mmap.obj cdata.obj + +GC_OBJS = alloc.obj gbc.obj + +OBJS = main.obj symbol.obj package.obj cons.obj list.obj\ + eval.obj interpreter.obj compiler.obj disassembler.obj \ + reference.obj character.obj file.obj error.obj \ + string.obj cfun.obj typespec.obj assignment.obj \ + predicate.obj big.obj array.obj vector_push.obj \ sequence.obj cmpaux.obj\ - macros.obj backq.obj stacks.obj \ - time.obj unixint.obj memory.obj \ + macros.obj backq.obj stack2.obj \ + time.obj unixint.obj \ mapfun.obj multival.obj hash.obj format.obj pathname.obj\ - structure.obj load.obj unixfsys.obj unixsys.obj \ - ffi.obj alloc_2.obj tcp.obj $(THREADS_OBJ) process.obj serialize.obj \ - $(ECL_UCD_OBJ) $(ECL_SSE_OBJ) + structure.obj load.obj unixfsys.obj unixsys.obj serialize.obj \ + mem_gc.obj tcp.obj \ + $(NUCL_OBJS) $(CLOS_OBJS) $(NUM_OBJS) $(FFI_OBJS) \ + $(WRITER_OBJS) $(READER_OBJS) $(THREADS_OBJ) \ + $(ECL_UCD_OBJ) $(ECL_SSE_OBJ) $(NUCL_OBJS) all: $(DPP) ..\eclmin.lib ..\cinit.obj diff --git a/src/aclocal.m4 b/src/aclocal.m4 index b24eb4df27ddf146f8d12d4ef223472287b55efb..d441f64673e8a4728255f364bde0f50bd2297f8c 100644 --- a/src/aclocal.m4 +++ b/src/aclocal.m4 @@ -263,9 +263,10 @@ SHAREDPREFIX='lib' LIBPREFIX='lib' LIBEXT='a' PICFLAG='-fPIC' -THREAD_CFLAGS='' +THREAD_CFLAGS='-DGC_NO_THREAD_REDIRECTS' THREAD_LIBS='' THREAD_GC_FLAGS='--enable-threads=posix' +CFLAGS='' INSTALL_TARGET='install' THREAD_OBJ="$THREAD_OBJ threads/thread threads/mutex threads/condition_variable threads/semaphore threads/barrier threads/mailbox threads/rwlock" clibs='-lm' @@ -274,7 +275,7 @@ SONAME_LDFLAGS='' case "${host_os}" in linux-android*) thehost='android' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" # THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -290,7 +291,7 @@ case "${host_os}" in # libdir may have a dollar expression inside linux*) thehost='linux' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -303,7 +304,7 @@ case "${host_os}" in ;; gnu*) thehost='gnu' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -315,7 +316,7 @@ case "${host_os}" in ;; kfreebsd*-gnu) thehost='kfreebsd' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -357,8 +358,6 @@ case "${host_os}" in ;; openbsd*) thehost='openbsd' - THREAD_CFLAGS='' - THREAD_LIBS='' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH="-Wl,--rpath,~A" @@ -386,7 +385,7 @@ case "${host_os}" in thehost='cygwin' #enable_threads='no' shared='yes' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -406,7 +405,7 @@ case "${host_os}" in clibs='' shared='yes' enable_threads='yes' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_GC_FLAGS='--enable-threads=win32' SHARED_LDFLAGS="-Wl,--stack,${ECL_DEFAULT_C_STACK_SIZE}" BUNDLE_LDFLAGS="-Wl,--stack,${ECL_DEFAULT_C_STACK_SIZE}" @@ -424,7 +423,7 @@ case "${host_os}" in SHARED_LDFLAGS="-dynamiclib ${LDFLAGS}" BUNDLE_LDFLAGS="-bundle ${LDFLAGS}" ECL_LDRPATH='-Wl,-rpath,~A' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' # The GMP library has not yet been ported to Intel or Arm-OSX case "`uname -m`" in @@ -457,7 +456,7 @@ case "${host_os}" in thehost='nonstop' shared='yes' PICFLAG='-call_shared' - THREAD_CFLAGS='-spthread' + THREAD_CFLAGS="-spthread ${THREAD_CFLAGS}" SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH='-Wld=\"-rld_l ~A\"' @@ -465,7 +464,6 @@ case "${host_os}" in ;; haiku*) thehost='haiku' - THREAD_LIBS='' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH="-Wl,--rpath,~A" @@ -492,7 +490,7 @@ esac case "${host}" in *-nacl) thehost='linux' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -504,7 +502,7 @@ case "${host}" in ;; *-pnacl) thehost='linux' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' dnl SHARED_LDFLAGS="-shared ${LDFLAGS}" dnl BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -1130,7 +1128,6 @@ if test "${enable_boehm}" = auto -o "${enable_boehm}" = system; then fi else FASL_LIBS="${FASL_LIBS} -lgc" - EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}" AC_DEFINE(GBC_BOEHM, [1], [Use Boehm's garbage collector]) fi fi @@ -1162,7 +1159,6 @@ if test "${enable_boehm}" = "included"; then ECL_BOEHM_GC_HEADER='ecl/gc/gc.h' SUBDIRS="${SUBDIRS} gc" CORE_LIBS="-leclgc ${CORE_LIBS}" - EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}" if test "${enable_shared}" = "no"; then LIBRARIES="${LIBRARIES} ${LIBPREFIX}eclgc.${LIBEXT}" fi @@ -1237,7 +1233,6 @@ if test "${enable_libffi}" = "included"; then ECL_LIBFFI_HEADER='ecl/ffi.h' SUBDIRS="${SUBDIRS} libffi" CORE_LIBS="-leclffi ${CORE_LIBS}" - EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}" if test "${enable_shared}" = "no"; then LIBRARIES="${LIBRARIES} ${LIBPREFIX}eclffi.${LIBEXT}" fi diff --git a/src/c/Makefile.in b/src/c/Makefile.in index 355348014b8c04e2fdc1bc426fbc56f4f9840d47..3bb706edf77744966571d70fa4a066ad200ee4d8 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -40,42 +40,50 @@ includedir=@includedir@ # Files HDIR = ../ecl -HFILES = $(HDIR)/config.h $(HDIR)/ecl.h $(HDIR)/ecl-cmp.h \ - $(HDIR)/object.h $(HDIR)/cs.h $(HDIR)/stacks.h \ - $(HDIR)/external.h $(HDIR)/cons.h $(HDIR)/legacy.h \ - $(HDIR)/number.h $(HDIR)/page.h $(HDIR)/bytecodes.h \ - $(HDIR)/cache.h $(HDIR)/config-internal.h $(HDIR)/ecl_atomics.h \ - $(HDIR)/ecl-inl.h $(HDIR)/internal.h $(HDIR)/stack-resize.h \ - $(HDIR)/threads.h $(HDIR)/impl/math_dispatch2.h \ - $(HDIR)/impl/math_dispatch.h $(HDIR)/impl/math_fenv.h \ - $(HDIR)/impl/math_fenv_msvc.h + +HFILES = $(HDIR)/config.h $(HDIR)/ecl.h $(HDIR)/ecl-cmp.h $(HDIR)/object.h \ + $(HDIR)/cs.h $(HDIR)/stacks.h $(HDIR)/external.h $(HDIR)/cons.h \ + $(HDIR)/legacy.h $(HDIR)/number.h $(HDIR)/page.h $(HDIR)/bytecodes.h \ + $(HDIR)/cache.h $(HDIR)/config-internal.h $(HDIR)/ecl_atomics.h \ + $(HDIR)/ecl-inl.h $(HDIR)/internal.h $(HDIR)/stack-resize.h \ + $(HDIR)/threads.h $(HDIR)/impl/math_dispatch2.h \ + $(HDIR)/impl/math_dispatch.h $(HDIR)/impl/math_fenv.h \ + $(HDIR)/impl/math_fenv_msvc.h $(HDIR)/nucleus.h + +NUCL_OBJS = boot.o call.o jump.o atomic.o process.o memory.o module.o stacks.o + CLOS_OBJS = clos/cache.o clos/accessor.o clos/instance.o clos/gfun.o -OBJS = main.o symbol.o package.o cons.o list.o apply.o eval.o \ - interpreter.o compiler.o disassembler.o $(CLOS_OBJS) \ - reference.o character.o file.o read.o print.o error.o \ - string.o cfun.o reader/parse_integer.o reader/parse_number.o \ - printer/float_to_digits.o printer/float_to_string.o \ - printer/integer_to_string.o printer/write_ugly.o \ - printer/write_object.o printer/write_symbol.o \ - printer/write_array.o printer/write_list.o \ - printer/write_code.o printer/write_sse.o \ - printer/print_unreadable.o ffi/libraries.o ffi/backtrace.o \ - ffi/mmap.o ffi/cdata.o numbers/cos.o numbers/sin.o \ - numbers/tan.o numbers/atan.o numbers/cosh.o numbers/sinh.o \ - numbers/tanh.o numbers/exp.o numbers/expt.o numbers/log.o \ - numbers/sqrt.o numbers/abs.o numbers/zerop.o numbers/plusp.o \ - numbers/minusp.o numbers/negate.o numbers/conjugate.o \ - numbers/one_plus.o numbers/one_minus.o numbers/plus.o \ - numbers/minus.o numbers/times.o numbers/divide.o \ - numbers/number_compare.o numbers/number_equalp.o \ - numbers/minmax.o numbers/floor.o numbers/ceiling.o \ - numbers/round.o numbers/truncate.o typespec.o assignment.o \ - memory.o predicate.o number.o num_pred.o num_arith.o num_co.o \ - num_log.o num_rand.o array.o vector_push.o sequence.o \ - cmpaux.o macros.o backq.o stacks.o time.o unixint.o mapfun.o \ - multival.o hash.o format.o pathname.o structure.o load.o \ - unixfsys.o unixsys.o serialize.o ffi.o sse2.o @EXTRA_OBJS@ \ - threads/atomic.o process.o + +NUM_OBJS = number.o num_pred.o num_arith.o num_co.o num_log.o num_rand.o \ + numbers/cos.o numbers/sin.o numbers/tan.o numbers/atan.o \ + numbers/cosh.o numbers/sinh.o numbers/tanh.o numbers/exp.o \ + numbers/expt.o numbers/log.o numbers/sqrt.o numbers/abs.o \ + numbers/zerop.o numbers/plusp.o numbers/minusp.o numbers/negate.o \ + numbers/conjugate.o numbers/one_plus.o numbers/one_minus.o \ + numbers/plus.o numbers/minus.o numbers/times.o numbers/divide.o \ + numbers/number_compare.o numbers/number_equalp.o numbers/minmax.o \ + numbers/floor.o numbers/ceiling.o numbers/round.o numbers/truncate.o + +WRITER_OBJS = print.o printer/float_to_digits.o printer/float_to_string.o \ + printer/integer_to_string.o printer/write_ugly.o \ + printer/write_object.o printer/write_symbol.o printer/write_array.o \ + printer/write_list.o printer/write_code.o printer/write_sse.o \ + printer/print_unreadable.o + +READER_OBJS = read.o reader/parse_integer.o reader/parse_number.o + +FFI_OBJS = ffi.o ffi/libraries.o ffi/backtrace.o ffi/mmap.o ffi/cdata.o + +GC_OBJS = alloc.o gbc.o + +OBJS = main.o symbol.o package.o cons.o list.o eval.o interpreter.o \ + compiler.o disassembler.o reference.o character.o file.o error.o \ + string.o cfun.o typespec.o assignment.o predicate.o array.o \ + vector_push.o sequence.o cmpaux.o macros.o backq.o stack2.o time.o \ + unixint.o mapfun.o multival.o hash.o format.o pathname.o structure.o \ + load.o unixfsys.o unixsys.o serialize.o sse2.o mem_gc.o \ + $(CLOS_OBJS) $(NUM_OBJS) $(WRITER_OBJS) $(READER_OBJS) $(FFI_OBJS) \ + $(NUCL_OBJS) @EXTRA_OBJS@ .PHONY: all diff --git a/src/c/all_symbols.d b/src/c/all_symbols.d index aba1f51ef54b5375741c4d7c1646102bac0f75a5..47a0601c862af256195879fcb408ca2e8137a89d 100644 --- a/src/c/all_symbols.d +++ b/src/c/all_symbols.d @@ -290,8 +290,8 @@ init_all_symbols(void) cl_object s, value; cl_objectfn fun; - /* We skip NIL and T */ - for (i = 2; cl_symbols[i].init.name != NULL; i++) { + /* We skip ECL_NIL_SYMBOL */ + for (i = 1; cl_symbols[i].init.name != NULL; i++) { s = (cl_object)(cl_symbols + i); code = cl_symbols[i].init.type; name = cl_symbols[i].init.name; diff --git a/src/c/threads/atomic.d b/src/c/atomic.d similarity index 81% rename from src/c/threads/atomic.d rename to src/c/atomic.d index b6d3e610993415c71d940ddc1ca6869f6aebd364..91d17c7e30e00563498c7d55772e52c3b9f616b8 100644 --- a/src/c/threads/atomic.d +++ b/src/c/atomic.d @@ -2,7 +2,7 @@ /* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - * atomic.d - atomic operations + * atomic.c - atomic operations * * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya * Copyright (c) 1990 Giuseppe Attardi @@ -27,14 +27,15 @@ ecl_atomic_get(cl_object *slot) return old; } -void -ecl_atomic_push(cl_object *slot, cl_object c) +cl_object +ecl_atomic_psh(cl_object *slot, cl_object cons) { - cl_object cons = ecl_list1(c), car; + cl_object cdr; do { - car = (cl_object)AO_load((AO_t*)slot); - ECL_RPLACD(cons, car); - } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)car, (AO_t)cons)); + cdr = (cl_object)AO_load((AO_t*)slot); + ECL_RPLACD(cons, cdr); + } while (!AO_compare_and_swap_full((AO_t*)slot, (AO_t)cdr, (AO_t)cons)); + return cdr; } cl_object diff --git a/src/c/big.d b/src/c/big.d index 5ea01ea228439f135617217ecda56a38e6944c15..9a69931cdb6b7463146e272f7af338b6d4da6b26 100644 --- a/src/c/big.d +++ b/src/c/big.d @@ -14,10 +14,13 @@ */ #define ECL_INCLUDE_MATH_H -#include -#include #include +#include #include +#include + +#include +#include /************************************************************* * MEMORY MANAGEMENT WITH GMP @@ -326,22 +329,20 @@ _ecl_fix_divided_by_big(cl_fixnum x, cl_object y) static void * mp_alloc(size_t size) { - return ecl_alloc_uncollectable(size); + return ecl_malloc(size); } static void mp_free(void *ptr, size_t size) { - ecl_free_uncollectable(ptr); + ecl_free(ptr); } static void * mp_realloc(void *ptr, size_t osize, size_t nsize) { - mp_limb_t *p = mp_alloc(nsize); - memcpy(p, ptr, (osize < nsize)? osize : nsize); - mp_free(ptr, osize); - return p; + ptr = ecl_realloc(ptr, osize, nsize); + return ptr; } #ifdef ECL_GMP_FIXNUM_TO_LIMBS @@ -607,29 +608,52 @@ _ecl_big_boole_operator(int op) return bignum_operations[op]; } -void +/* -- module definition ------------------------------------------------------ */ + +static cl_object +create_bignum () +{ + if (ecl_option_values[ECL_OPT_SET_GMP_MEMORY_FUNCTIONS]) + mp_set_memory_functions(mp_alloc, mp_realloc, mp_free); + return ECL_NIL; +} + +cl_object ecl_init_bignum_registers(cl_env_ptr env) { int i; for (i = 0; i < ECL_BIGNUM_REGISTER_NUMBER; i++) { + /* INV this implies the standard allocator already initialized. */ cl_object x = ecl_alloc_object(t_bignum); _ecl_big_init2(x, ECL_BIG_REGISTER_SIZE); env->big_register[i] = x; } + return ECL_NIL; } -void -ecl_clear_bignum_registers(cl_env_ptr env) +cl_object +ecl_free_bignum_registers(cl_env_ptr env) { int i; for (i = 0; i < ECL_BIGNUM_REGISTER_NUMBER; i++) { _ecl_big_clear(env->big_register[i]); + env->big_register[i] = ECL_NIL; } + return ECL_NIL; } -void -init_big() -{ - if (ecl_option_values[ECL_OPT_SET_GMP_MEMORY_FUNCTIONS]) - mp_set_memory_functions(mp_alloc, mp_realloc, mp_free); -} +ecl_def_ct_base_string(str_bignum, "BIGNUM", 6, static, const); + +static struct ecl_module module_bignum = { + .name = str_bignum, + .create = create_bignum, + .enable = ecl_module_no_op, + .init_env = ecl_init_bignum_registers, + .init_cpu = ecl_module_no_op_cpu, + .free_cpu = ecl_module_no_op_cpu, + .free_env = ecl_free_bignum_registers, + .disable = ecl_module_no_op, + .destroy = ecl_module_no_op +}; + +cl_object ecl_module_bignum = (cl_object)&module_bignum; diff --git a/src/c/boot.d b/src/c/boot.d new file mode 100644 index 0000000000000000000000000000000000000000..1a53b386f3c6695b4997d372905c1e389898367b --- /dev/null +++ b/src/c/boot.d @@ -0,0 +1,291 @@ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ + +/* boot.c - initializing ecl internal data */ + +/* -- imports --------------------------------------------------------------- */ + +#include +#include +#include +#include + +#ifdef ECL_USE_MPROTECT +# include +# ifndef MAP_FAILED +# define MAP_FAILED -1 +# endif +#endif +#include +#include +#include +#include +#if defined(ECL_MS_WINDOWS_HOST) +# include +# include +# define MAXPATHLEN 512 +#endif +#ifndef MAXPATHLEN +# ifdef PATH_MAX +# define MAXPATHLEN PATH_MAX +# else +# define MAXPATHLEN sysconf(_PC_PATH_MAX) +# include +# endif +#endif + +/* -- constants ----------------------------------------------------- */ + +const cl_object ecl_ct_Jan1st1970UT = ecl_make_fixnum(39052800); + +ecl_def_ct_base_string(ecl_ct_null_string,"",0,,const); + +ecl_def_ct_single_float(ecl_ct_default_rehash_size,1.5f,,const); +ecl_def_ct_single_float(ecl_ct_default_rehash_threshold,0.75f,,const); + +ecl_def_ct_single_float(ecl_ct_singlefloat_zero,0,,const); +ecl_def_ct_double_float(ecl_ct_doublefloat_zero,0,,const); +ecl_def_ct_long_float(ecl_ct_longfloat_zero,0,,const); + +ecl_def_ct_single_float(ecl_ct_singlefloat_minus_zero,-0.0,,const); +ecl_def_ct_double_float(ecl_ct_doublefloat_minus_zero,-0.0,,const); +ecl_def_ct_long_float(ecl_ct_longfloat_minus_zero,-0.0l,,const); + +ecl_def_ct_ratio(ecl_ct_plus_half,ecl_make_fixnum(1),ecl_make_fixnum(2),,const); +ecl_def_ct_ratio(ecl_ct_minus_half,ecl_make_fixnum(-1),ecl_make_fixnum(2),,const); + +/* These two tags have a special meaning for the frame stack. */ +ecl_def_constant(ecl_ct_protect_tag, ECL_NIL, "PROTECT-TAG", 11); +ecl_def_constant(ecl_ct_dummy_tag, ECL_NIL, "DUMMY-TAG", 9); + +struct ecl_symbol +ecl_symbols[] = { + /* This variable contains handlers for signals and exceptions. */ + ecl_constexpr_symbol(ecl_stp_special, "*SIGNAL-HANDLERS*", ECL_NIL), + /* Restart clusters allow us to estabilish selectable correction actions. */ + ecl_constexpr_symbol(ecl_stp_special, "*RESTART-CLUSTERS*", ECL_NIL), + /* This variable allows for interrupting sygnals from Lisp.. */ + ecl_constexpr_symbol(ecl_stp_special, "*INTERRUPTS-ENABLED*", ECL_T), + /* OP_PUSHKEYS handles specially :ALLOW-OTHER-KEYS (per CL semantics). */ + ecl_constexpr_symbol(ecl_stp_constant, "ALLOW-OTHER-KEYS", ECL_ALLOW_OTHER_KEYS), + /* The universal truth, the supertype of all, the class above classes. */ + ecl_constexpr_symbol(ecl_stp_constant, "T", ECL_T), + /* The marker for unbound slots. This is more a tag than a symbol. */ + ecl_constexpr_symbol(ecl_stp_constant, "UNBOUND", ECL_UNBOUND), +}; + +/* -- implementation ------------------------------------------------ */ + +#if ECL_FIXNUM_BITS <= 32 +/* 1GB */ +#define ECL_DEFAULT_HEAP_SIZE 1073741824L +#else +/* 4GB */ +#define ECL_DEFAULT_HEAP_SIZE 4294967296L +#endif + +#ifndef ECL_DEFAULT_C_STACK_SIZE +#define ECL_DEFAULT_C_STACK_SIZE 0 +#endif + +#ifdef GBC_BOEHM_GENGC +#define ECL_INCREMENTAL_GC 1 +#else +#define ECL_INCREMENTAL_GC 0 +#endif + +#if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK) +#define ECL_SIGNAL_HANDLING_THREAD 1 +#else +#define ECL_SIGNAL_HANDLING_THREAD 0 +#endif + +/* INV: see ecl_option enum in external.h */ +cl_fixnum ecl_option_values[ECL_OPT_LIMIT+1] = { + /* ---------------------------------------------------------------- */ + ECL_INCREMENTAL_GC, /* ECL_OPT_INCREMENTAL_GC */ + 1, /* ECL_OPT_TRAP_SIGSEGV */ + 1, /* ECL_OPT_TRAP_SIGFPE */ + 1, /* ECL_OPT_TRAP_SIGINT */ + 1, /* ECL_OPT_TRAP_SIGILL */ + 1, /* ECL_OPT_TRAP_SIGBUS */ + 1, /* ECL_OPT_TRAP_SIGPIPE */ + 1, /* ECL_OPT_TRAP_INTERRUPT_SIGNAL */ + ECL_SIGNAL_HANDLING_THREAD, /* ECL_OPT_SIGNAL_HANDLING_THREAD */ + 16, /* ECL_OPT_SIGNAL_QUEUE_SIZE */ + 0, /* ECL_OPT_BOOTED */ + /* ---------------------------------------------------------------- */ + 8192, /* ECL_OPT_BIND_STACK_SIZE */ + 1024, /* ECL_OPT_BIND_STACK_SAFETY_AREA */ + 2048, /* ECL_OPT_FRAME_STACK_SIZE */ + 128, /* ECL_OPT_FRAME_STACK_SAFETY_AREA */ + 32768, /* ECL_OPT_LISP_STACK_SIZE */ + 128, /* ECL_OPT_LISP_STACK_SAFETY_AREA */ + ECL_DEFAULT_C_STACK_SIZE, /* ECL_OPT_C_STACK_SIZE */ + 4*sizeof(cl_index)*1024, /* ECL_OPT_C_STACK_SAFETY_AREA */ + ECL_DEFAULT_HEAP_SIZE, /* ECL_OPT_HEAP_SIZE */ + 1024*1024, /* ECL_OPT_HEAP_SAFETY_AREA */ + 0, /* ECL_OPT_THREAD_INTERRUPT_SIGNAL */ + 1, /* ECL_OPT_SET_GMP_MEMORY_FUNCTIONS */ + 1, /* ECL_OPT_USE_SETMODE_ON_FILES */ + /* ---------------------------------------------------------------- */ + 0}; + +cl_fixnum +ecl_get_option(int option) +{ + if (option >= ECL_OPT_LIMIT || option < 0) { + return -1; + } + return ecl_option_values[option]; +} + +cl_fixnum +ecl_set_option(int option, cl_fixnum value) +{ + if (option > ECL_OPT_LIMIT || option < 0) { + return -1; + } + if (option >= ECL_OPT_BOOTED || !ecl_option_values[ECL_OPT_BOOTED]) { + ecl_option_values[option] = value; + } + return ecl_option_values[option]; +} + +/* -- environments ---------------------------------------------------------- */ + +#ifdef ECL_THREADS +static void +add_env(cl_env_ptr the_env) +{ + cl_object _env; + ecl_mutex_lock(&ecl_core.processes_lock); + _env = ecl_cast_ptr(cl_object,the_env); + ecl_stack_push(ecl_core.threads, _env); + ecl_mutex_unlock(&ecl_core.processes_lock); +} + +static void +del_env(cl_env_ptr the_env) +{ + cl_object _env; + ecl_mutex_lock(&ecl_core.processes_lock); + _env = ecl_cast_ptr(cl_object,the_env); + ecl_stack_del(ecl_core.threads, _env); + ecl_mutex_unlock(&ecl_core.processes_lock); +} +#endif + +cl_env_ptr +_ecl_alloc_env(cl_env_ptr parent) +{ + /* Allocates the lisp environment for a thread. Depending on which mechanism + * we use for detecting delayed signals, we may allocate the environment using + * mmap or with malloc. + * + * Note that at this point we are not allocating any other memory which is + * stored via a pointer in the environment. If we would do that, an unlucky + * interrupt by the gc before the allocated environment is registered in + * ecl_core.processes could lead to memory being freed because the gc is not + * aware of the pointer to the allocated memory in the environment. */ + cl_env_ptr output; +#if defined(ECL_USE_MPROTECT) + output = (cl_env_ptr) mmap(0, sizeof(*output), PROT_READ | PROT_WRITE, + MAP_ANON | MAP_PRIVATE, -1, 0); + if (output == MAP_FAILED) + ecl_internal_error("Unable to allocate environment structure."); +#else +# if defined(ECL_USE_GUARD_PAGE) + output = VirtualAlloc(0, sizeof(*output), MEM_COMMIT, PAGE_READWRITE); + if (output == NULL) + ecl_internal_error("Unable to allocate environment structure."); +# else + output = ecl_malloc(sizeof(*output)); + if (output == NULL) + ecl_internal_error("Unable to allocate environment structure."); +# endif +#endif + /* Initialize the structure with NULL data. */ + memset(output, 0, sizeof(*output)); +#ifdef ECL_THREADS + add_env(output); +#endif + return output; +} + +void +_ecl_dealloc_env(cl_env_ptr env) +{ +#ifdef ECL_THREADS + del_env(env); +#endif +#if defined(ECL_USE_MPROTECT) + if (munmap(env, sizeof(*env))) + ecl_internal_error("Unable to deallocate environment structure."); +#elif defined(ECL_USE_GUARD_PAGE) + if (!VirtualFree(env, 0, MEM_RELEASE)) + ecl_internal_error("Unable to deallocate environment structure."); +#else + ecl_free_unsafe(env); +#endif +} + +/* -- core runtime ---------------------------------------------------------- */ + +/* The root environment is a default execution context. */ +static struct cl_env_struct first_env; + +struct ecl_core_struct ecl_core = { + .first_env = &first_env, + /* processes */ +#ifdef ECL_THREADS + .threads = ECL_NIL, + .last_var_index = 0, + .reused_indices = ECL_NIL, +#endif + /* signals */ + .default_sigmask_bytes = 0, + .known_signals = ECL_NIL, + /* allocation */ + .max_heap_size = 0, + .bytes_consed = ECL_NIL, + .gc_counter = ECL_NIL, + .gc_stats = 0, + .safety_region = NULL, + /* pathnames */ + .path_max = 0, + .pathname_translations = ECL_NIL, + /* MODULES is a stack of plugins that may be loaded at boot time. */ + .modules = ECL_NIL, + /* LIBRARIES is a list of objects. It behaves as a sequence of weak pointers + thanks to the magic in the garbage collector. */ + .libraries = ECL_NIL, + .library_pathname = ECL_NIL +}; + +/* note that this function does not create any environment */ +int +ecl_boot(void) +{ + int i; + + i = ecl_option_values[ECL_OPT_BOOTED]; + if (i) { + if (i < 0) { + /* We have called cl_shutdown and want to use ECL again. */ + ecl_set_option(ECL_OPT_BOOTED, 1); + } + return 1; + } + init_modules(); + ecl_core.path_max = MAXPATHLEN; + + return 0; +} + +int +ecl_halt(void) +{ + ecl_set_option(ECL_OPT_BOOTED, -1); + return 0; +} diff --git a/src/c/apply.d b/src/c/call.d similarity index 95% rename from src/c/apply.d rename to src/c/call.d index 12a27e74e4d4137c2b2f2ba1b3e9d07ecf769009..aac0c1cb7e281016ee939d86430bf2452e7b9dc2 100644 --- a/src/c/apply.d +++ b/src/c/call.d @@ -1,18 +1,93 @@ /* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ /* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ -/* - * apply.c - interface to C call mechanism - * - * Copyright (c) 1993 Giuseppe Attardi - * Copyright (c) 2001 Juan Jose Garcia Ripoll +/* dispatch.c - function application */ + +#include +#include +#include +#include +#include + +cl_objectfn +ecl_function_dispatch(cl_env_ptr env, cl_object x) +{ + cl_object fun = x; + if (ecl_unlikely(fun == ECL_NIL)) + ecl_ferror(ECL_EX_F_UNDEF, fun, ECL_NIL); + switch (ecl_t_of(fun)) { + case t_cfunfixed: + env->function = fun; + return fun->cfunfixed.entry; + case t_cfun: + env->function = fun; + return fun->cfun.entry; + case t_cclosure: + env->function = fun; + return fun->cclosure.entry; + case t_instance: + env->function = fun; + return fun->instance.entry; + case t_symbol: + fun = ECL_SYM_FUN(fun); + env->function = fun; + return fun->cfun.entry; + case t_bytecodes: + env->function = fun; + return fun->bytecodes.entry; + case t_bclosure: + env->function = fun; + return fun->bclosure.entry; + default: + ecl_ferror(ECL_EX_F_INVAL, fun, ECL_NIL); + } + _ecl_unexpected_return(); +} + +/* Calling conventions: + * Compiled C code calls lisp function supplying #args, and args. * - * See file 'LICENSE' for the copyright details. + * Linking function performs check_args, gets jmp_buf with _setjmp, then * + * if cfun then stores C code address into function link location and transfers + * to jmp_buf at cf_self + + * if cclosure then replaces #args with cc_env and calls cc_self otherwise, it + * emulates funcall. */ -#include -#include +cl_object +ecl_apply_from_stack_frame(cl_object frame, cl_object x) +{ + cl_object *sp = ECL_STACK_FRAME_PTR(frame); + cl_index narg = frame->frame.size; + cl_env_ptr env = frame->frame.env; + cl_objectfn entry = ecl_function_dispatch(env, x); + cl_object ret; + env->stack_frame = frame; + ret = APPLY(narg, entry, sp); + env->stack_frame = NULL; + return ret; +} + +cl_object +cl_funcall(cl_narg narg, cl_object function, ...) +{ + cl_object output; + --narg; + { + ECL_STACK_FRAME_VARARGS_BEGIN(narg, function, frame); + output = ecl_apply_from_stack_frame(frame, function); + ECL_STACK_FRAME_VARARGS_END(frame); + } + return output; +} + +cl_object * +_ecl_va_sp(cl_narg narg) +{ + return ECL_STACK_FRAME_PTR(ecl_process_env()->stack_frame) + narg; +} #if !(ECL_C_ARGUMENTS_LIMIT == 63) #error "Please adjust code to the constant!" @@ -656,6 +731,7 @@ APPLY_fixed(cl_narg n, cl_object (*fn)(), cl_object *x) x[50],x[51],x[52],x[53],x[54],x[55],x[56], x[57],x[58],x[59],x[60],x[61],x[62]); default: - FEprogram_error("Too many arguments", 0); + ecl_ferror(ECL_EX_F_NARGS, ecl_make_fixnum(n), ECL_NIL); } + _ecl_unexpected_return(); } diff --git a/src/c/cinit.d b/src/c/cinit.d index 8f81d28d462a342857a0d5cf9810f7ce9a80e00a..286391b3a780b09e783a4bb404093a0a4149a605 100644 --- a/src/c/cinit.d +++ b/src/c/cinit.d @@ -68,7 +68,7 @@ si_bind_simple_restarts(cl_object tag, cl_object names) if (ECL_FBOUNDP(@'si::bind-simple-restarts')) return _ecl_funcall3(@'si::bind-simple-restarts', tag, names); else - return ECL_SYM_VAL(ecl_process_env(), @'si::*restart-clusters*'); + return ECL_SYM_VAL(ecl_process_env(), ECL_RESTART_CLUSTERS); } extern cl_object @@ -77,7 +77,7 @@ si_bind_simple_handlers(cl_object tag, cl_object names) if (ECL_FBOUNDP(@'si::bind-simple-handlers')) return _ecl_funcall3(@'si::bind-simple-handlers', tag, names); else - return ECL_SYM_VAL(ecl_process_env(), @'si::*handler-clusters*'); + return ECL_SYM_VAL(ecl_process_env(), ECL_SIGNAL_HANDLERS); } extern cl_object diff --git a/src/c/clos/instance.d b/src/c/clos/instance.d index e589692b0797cde853c4f21ff938baf60e234efe..8d1fd5bbdcae0c890b4baa83e59db530fa362d16 100644 --- a/src/c/clos/instance.d +++ b/src/c/clos/instance.d @@ -383,6 +383,8 @@ enum ecl_built_in_classes { ECL_BUILTIN_CODE_BLOCK, ECL_BUILTIN_FOREIGN_DATA, ECL_BUILTIN_FRAME, + ECL_BUILTIN_EXCEPTION, + ECL_BUILTIN_MODULE, ECL_BUILTIN_WEAK_POINTER #ifdef ECL_THREADS , @@ -505,6 +507,10 @@ cl_class_of(cl_object x) index = ECL_BUILTIN_FOREIGN_DATA; break; case t_frame: index = ECL_BUILTIN_FRAME; break; + case t_exception: + index = ECL_BUILTIN_EXCEPTION; break; + case t_module: + index = ECL_BUILTIN_MODULE; break; case t_weak_pointer: index = ECL_BUILTIN_WEAK_POINTER; break; #ifdef ECL_SSE2 diff --git a/src/c/cmpaux.d b/src/c/cmpaux.d index 331d5cfd571ac76a3403d6cb7f1cd165558b2db3..66d03c09d965c1351beb661cbaa81161ec515d0f 100644 --- a/src/c/cmpaux.d +++ b/src/c/cmpaux.d @@ -129,37 +129,6 @@ ecl_aset_bv(cl_object x, cl_index index, int value) return value; } -void -cl_throw(cl_object tag) -{ - ecl_frame_ptr fr = frs_sch(tag); - if (fr == NULL) - FEcontrol_error("THROW: The catch ~S is undefined.", 1, tag); - ecl_unwind(ecl_process_env(), fr); -} - -void -cl_return_from(cl_object block_id, cl_object block_name) -{ - ecl_frame_ptr fr = frs_sch(block_id); - if (fr == NULL) - FEcontrol_error("RETURN-FROM: The block ~S with id ~S is missing.", - 2, block_name, block_id); - ecl_unwind(ecl_process_env(), fr); -} - -void -cl_go(cl_object tag_id, cl_object label) -{ - const cl_env_ptr the_env = ecl_process_env(); - ecl_frame_ptr fr = frs_sch(tag_id); - if (fr == NULL) - FEcontrol_error("GO: The tagbody ~S is missing.", 1, tag_id); - the_env->values[0] = label; - the_env->nvalues = 1; - ecl_unwind(the_env, fr); -} - cl_object cl_grab_rest_args(ecl_va_list args) { @@ -211,7 +180,7 @@ cl_parse_key( } } /* the key is a new one */ - if (keyword == @':allow-other-keys') { + if (keyword == ECL_ALLOW_OTHER_KEYS) { if (supplied_allow_other_keys == OBJNULL) supplied_allow_other_keys = value; } else if (unknown_keyword == OBJNULL) @@ -224,7 +193,8 @@ cl_parse_key( (supplied_allow_other_keys == ECL_NIL || supplied_allow_other_keys == OBJNULL))) { for (i = 0; i < nkey; i++) { - if (keys[i] == @':allow-other-keys' && vars[nkey+i] == ECL_T && !Null(vars[i])) { + if (keys[i] == ECL_ALLOW_OTHER_KEYS && vars[nkey+i] == ECL_T + && !Null(vars[i])) { return; } } diff --git a/src/c/compiler.d b/src/c/compiler.d index ee76b09507c8afb308c3ec53afb624c500401a52..72c2eba4016b20f2221ae5ffbc97e6467e29b615 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -53,9 +53,9 @@ typedef struct cl_compiler_env *cl_compiler_ptr; #define asm_begin(env) current_pc(env) -#define current_pc(env) ECL_STACK_INDEX(env) +#define current_pc(env) ecl_vms_index(env) #define set_pc(env,n) asm_clear(env,n) -#define asm_ref(env,n) (cl_fixnum)((env)->stack[n]) +#define asm_ref(env,n) (cl_fixnum)((env)->run_stack.org[n]) static void asm_clear(cl_env_ptr env, cl_index h); static void asm_op(cl_env_ptr env, cl_fixnum op); static void asm_op2(cl_env_ptr env, int op, int arg); @@ -192,7 +192,7 @@ asm_end(cl_env_ptr env, cl_index beginning, cl_object definition) { output->bytecodes.flex = ECL_NIL; output->bytecodes.nlcl = ecl_make_fixnum(c_env->env_width); for (i = 0, code = (cl_opcode *)output->bytecodes.code; i < code_size; i++) { - code[i] = (cl_opcode)(cl_fixnum)(env->stack[beginning+i]); + code[i] = (cl_opcode)(cl_fixnum)(env->run_stack.org[beginning+i]); } output->bytecodes.entry = _ecl_bytecodes_dispatch_vararg; ecl_set_function_source_file_info(output, (file == OBJNULL)? ECL_NIL : file, @@ -206,12 +206,12 @@ asm_end(cl_env_ptr env, cl_index beginning, cl_object definition) { static void asm_op(cl_env_ptr env, cl_fixnum code) { cl_object v = (cl_object)code; - ECL_STACK_PUSH(env,v); + ecl_vms_push(env,v); } static void asm_clear(cl_env_ptr env, cl_index h) { - ECL_STACK_SET_INDEX(env, h); + ecl_vms_unwind(env, h); } static void @@ -257,7 +257,7 @@ asm_complete(cl_env_ptr env, int op, cl_index pc) { else if (ecl_unlikely(delta < -MAX_OPARG || delta > MAX_OPARG)) FEprogram_error("Too large jump", 0); else { - env->stack[pc] = (cl_object)(cl_fixnum)delta; + env->run_stack.org[pc] = (cl_object)(cl_fixnum)delta; } } @@ -1446,7 +1446,7 @@ c_catch(cl_env_ptr env, cl_object args, int flags) { static int c_compiler_let(cl_env_ptr env, cl_object args, int flags) { cl_object bindings; - cl_index old_bds_top_index = env->bds_top - env->bds_org; + cl_index old_bds_ndx = env->bds_stack.top - env->bds_stack.org; for (bindings = pop(&args); !Null(bindings); ) { cl_object form = pop(&bindings); @@ -1455,7 +1455,7 @@ c_compiler_let(cl_env_ptr env, cl_object args, int flags) { ecl_bds_bind(env, var, value); } flags = compile_toplevel_body(env, args, flags); - ecl_bds_unwind(env, old_bds_top_index); + ecl_bds_unwind(env, old_bds_ndx); return flags; } @@ -2813,7 +2813,7 @@ save_bytecodes(cl_env_ptr env, cl_index start, cl_index end) cl_object bytecodes = ecl_alloc_simple_vector(l, ecl_aet_index); cl_index *p; for (p = bytecodes->vector.self.index; end > start; end--, p++) { - *p = (cl_index)ECL_STACK_POP_UNSAFE(env); + *p = (cl_index)ecl_vms_popu(env); } return bytecodes; } @@ -2824,7 +2824,7 @@ restore_bytecodes(cl_env_ptr env, cl_object bytecodes) cl_index *p = bytecodes->vector.self.index; cl_index l; for (l = bytecodes->vector.dim; l; l--) { - ECL_STACK_PUSH(env, (cl_object)p[l-1]); + ecl_vms_push(env, (cl_object)p[l-1]); } ecl_dealloc(bytecodes); } @@ -3096,10 +3096,11 @@ c_cons_cdr(cl_env_ptr env, cl_object args, int flags) cl_object si_need_to_make_load_form_p(cl_object object) { - cl_object load_form_cache = cl__make_hash_table(@'eq', - ecl_make_fixnum(16), - cl_core.rehash_size, - cl_core.rehash_threshold); + cl_object load_form_cache = + cl__make_hash_table(@'eq', + ecl_make_fixnum(16), + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); cl_object waiting_objects = ecl_list1(object); cl_type type = t_start; @@ -3811,8 +3812,8 @@ init_compiler() cl_object dispatch_table = cl_core.compiler_dispatch = cl__make_hash_table(@'eq', ecl_make_fixnum(128), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); int i; for (i = 0; database[i].symbol; i++) { ecl_sethash(database[i].symbol, dispatch_table, ecl_make_fixnum(i)); diff --git a/src/c/error.d b/src/c/error.d index c98417ba2b8b8bd5e00b90ffe5ada481ecb8498e..ce707a87b85ec3508271c5a85281463660d6f6f6 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -24,69 +24,12 @@ #include #include -static cl_object -cl_symbol_or_object(cl_object x) -{ - if (ECL_FIXNUMP(x)) - return (cl_object)(cl_symbols + ecl_fixnum(x)); - return x; -} - -void -_ecl_unexpected_return() -{ - ecl_internal_error( - "*** \n" - "*** A call to ERROR returned without handling the error.\n" - "*** This should have never happened and is usually a signal\n" - "*** that the debugger or the universal error handler were\n" - "*** improperly coded or altered. Please contact the maintainers\n" - "***\n"); -} - -void -ecl_internal_error(const char *s) -{ - int saved_errno = errno; - fprintf(stderr, "\nInternal or unrecoverable error in:\n%s\n", s); - if (saved_errno) { - fprintf(stderr, " [%d: %s]\n", saved_errno, strerror(saved_errno)); - } - fflush(stderr); - _ecl_dump_c_backtrace(); -#ifdef SIGIOT - signal(SIGIOT, SIG_DFL); /* avoid getting into a loop with abort */ -#endif - abort(); -} - -#ifdef ECL_THREADS -void -ecl_thread_internal_error(const char *s) -{ - int saved_errno = errno; - fprintf(stderr, "\nInternal thread error in:\n%s\n", s); - if (saved_errno) { - fprintf(stderr, " [%d: %s]\n", saved_errno, strerror(saved_errno)); - } - _ecl_dump_c_backtrace(); - fprintf(stderr, - "\nDid you forget to call `ecl_import_current_thread'?\n" - "Exitting thread.\n"); - fflush(stderr); - ecl_thread_exit(); -} -#endif - void ecl_unrecoverable_error(cl_env_ptr the_env, const char *message) { - /* - * Right now we have no means of specifying a jump point - * for really bad events. We just jump to the outermost - * frame, which is equivalent to quitting, and wait for - * someone to intercept this jump. - */ + /* Right now we have no means of specifying a jump point for really bad + * events. We just jump to the outermost frame, which is equivalent to + * quitting, and wait for someone to intercept this jump. */ ecl_frame_ptr destination; cl_object tag; @@ -104,29 +47,118 @@ ecl_unrecoverable_error(cl_env_ptr the_env, const char *message) ecl_unwind(the_env, destination); } } - if (the_env->frs_org <= the_env->frs_top) { - destination = ecl_process_env()->frs_org; + if (the_env->frs_stack.org <= the_env->frs_stack.top) { + destination = ecl_process_env()->frs_stack.org; ecl_unwind(the_env, destination); } else { ecl_internal_error("\n;;;\n;;; No frame to jump to\n;;; Aborting ECL\n;;;"); } } -void -ecl_miscompilation_error() -{ - ecl_internal_error( - "***\n" - "*** Encountered a code path that should have never been taken.\n" - "*** This likely indicates a bug in the ECL compiler. Please contact\n" - "*** the maintainers.\n" - "***\n"); +/* -- Integration with low-level exceptions */ +cl_object +ecl_exception_handler(cl_object o) +{ + if (ECL_EXCEPTIONP(o)) { + cl_object arg1 = o->exception.arg1; + cl_object arg2 = o->exception.arg2; + cl_object hand = @'si::universal-error-handler'; + switch (o->exception.ex_type) { + /* General conditions */ + case ECL_EX_FERROR: + ecl_enable_interrupts(); + return _ecl_funcall4(hand, ECL_NIL, arg1, arg2); + case ECL_EX_CERROR: + ecl_enable_interrupts(); + return _ecl_funcall4(hand, ECL_T, arg1, arg2); + /* Stack conditions */ + case ECL_EX_CS_OVR: + CEstack_overflow(@'ext::c-stack', arg1, arg2); + break; + case ECL_EX_FRS_OVR: + CEstack_overflow(@'ext::frame-stack', arg1, arg2); + break; + case ECL_EX_BDS_OVR: + CEstack_overflow(@'ext::binding-stack', arg1, arg2); + break; + /* KLUDGE ByteVM-specific conditions */ + case ECL_EX_VM_BADARG_EXCD: + FEprogram_error("Too many arguments passed to function ~A~&" + "Argument list: ~S", + 2, arg1, cl_apply(2, @'list', arg2)); + break; + case ECL_EX_VM_BADARG_UNKK: + FEprogram_error("Unknown keyword argument passed to function ~A.~&" + "Argument list: ~S", + 2, arg1, cl_apply(2, @'list', arg2)); + break; + case ECL_EX_VM_BADARG_ODDK: + FEprogram_error("Odd number of keyword arguments passed to function ~A.~&" + "Argument list: ~S", + 2, arg1, cl_apply(2, @'list', arg2)); + break; + case ECL_EX_VM_BADARG_NTH_VAL: + FEerror("Wrong index passed to NTH-VAL", 0); + break; + case ECL_EX_VM_BADARG_ENDP: + FEwrong_type_only_arg(@[endp], arg1, @[list]); + break; + case ECL_EX_VM_BADARG_CAR: + FEwrong_type_only_arg(@[car], arg1, @[list]); + break; + case ECL_EX_VM_BADARG_CDR: + FEwrong_type_only_arg(@[cdr], arg1, @[list]); + break; + case ECL_EX_VM_BADARG_PROGV: + FEerror("Wrong arguments to special form PROGV. Either~%" + "~A~%or~%~A~%are not proper lists", + 2, arg1, arg2); + break; + /* Variable conditions */ + case ECL_EX_V_CSETQ: + FEassignment_to_constant(arg1); + break; + case ECL_EX_V_CBIND: + FEbinding_a_constant(arg1); + break; + case ECL_EX_V_UNBND: + FEunbound_variable(arg1); + break; + case ECL_EX_V_BNAME: + FEunbound_variable(arg1); + break; + /* Function conditions */ + case ECL_EX_F_NARGS: + FEwrong_num_arguments(arg1); + break; + case ECL_EX_F_UNDEF: + FEundefined_function(arg1); + break; + case ECL_EX_F_INVAL: + FEinvalid_function(arg1); + break; + case ECL_EX_S_FMISS: + FEcontrol_error("UNWIND: frame ~s not found.", 1, arg1); + break; + default: + ecl_internal_error("Unknown exception type."); + } + } + return ECL_NIL; } /*****************************************************************************/ /* Support for Lisp Error Handler */ /*****************************************************************************/ +static cl_object +cl_symbol_or_object(cl_object x) +{ + if (ECL_FIXNUMP(x)) + return (cl_object)(cl_symbols + ecl_fixnum(x)); + return x; +} + void FEerror(const char *s, int narg, ...) { @@ -162,6 +194,24 @@ CEerror(cl_object c, const char *err, int narg, ...) * Conditions signaler * ***********************/ +void +CEstack_overflow(cl_object type, cl_object limit, cl_object resume) +{ + cl_env_ptr the_env = ecl_process_env(); + cl_index the_size; + if (!Null(resume)) resume = @"Extend stack size"; + ECL_UNWIND_PROTECT_BEGIN(the_env) { + cl_cerror(6, resume, @'ext::stack-overflow', @':type', type, @':size', limit); + } ECL_UNWIND_PROTECT_EXIT { + /* reset the margin */ + si_set_limit(type, limit); + } ECL_UNWIND_PROTECT_END; + /* resize the stack */ + the_size = ecl_to_size(limit); + the_size = the_size + the_size/2; + si_set_limit(type, ecl_make_fixnum(the_size)); +} + void FEprogram_error(const char *s, int narg, ...) { @@ -287,7 +337,7 @@ FEwrong_type_only_arg(cl_object function, cl_object value, cl_object type) struct ecl_ihs_frame tmp_ihs; function = cl_symbol_or_object(function); type = cl_symbol_or_object(type); - if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { + if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) { ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); } si_signal_simple_error(8, @@ -311,7 +361,7 @@ FEwrong_type_nth_arg(cl_object function, cl_narg narg, cl_object value, cl_objec struct ecl_ihs_frame tmp_ihs; function = cl_symbol_or_object(function); type = cl_symbol_or_object(type); - if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { + if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) { ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); } si_signal_simple_error(8, @@ -337,7 +387,7 @@ FEwrong_type_key_arg(cl_object function, cl_object key, cl_object value, cl_obje function = cl_symbol_or_object(function); type = cl_symbol_or_object(type); key = cl_symbol_or_object(key); - if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { + if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) { ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); } si_signal_simple_error(8, @@ -368,7 +418,7 @@ FEwrong_index(cl_object function, cl_object a, int which, cl_object ndx, cl_env_ptr env = ecl_process_env(); struct ecl_ihs_frame tmp_ihs; function = cl_symbol_or_object(function); - if (!Null(function) && env->ihs_top && env->ihs_top->function != function) { + if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) { ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL); } cl_error(9, @@ -506,8 +556,7 @@ universal_error_handler(cl_object continue_string, cl_object datum, ecl_bds_bind(the_env, @'*print-length*', ecl_make_fixnum(8)); ecl_bds_bind(the_env, @'*print-circle*', ECL_NIL); ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10)); - writestr_stream("\n;;; Unhandled lisp initialization error", - stream); + writestr_stream("\n;;; Unhandled lisp initialization error", stream); writestr_stream("\n;;; Message:\n", stream); si_write_ugly_object(datum, stream); writestr_stream("\n;;; Arguments:\n", stream); @@ -601,17 +650,9 @@ FEwin32_error(const char *msg, int narg, ...) cl_grab_rest_args(args))); } @) -@(defun si::serror (cformat eformat &rest args) -@ { - ecl_enable_interrupts(); - @(return funcall(4, @'si::stack-error-handler', cformat, eformat, - cl_grab_rest_args(args))); -} @) - void init_error(void) { ecl_def_c_function(@'si::universal-error-handler', - (cl_objectfn_fixed)universal_error_handler, - 3); + (cl_objectfn_fixed)universal_error_handler, 3); } diff --git a/src/c/eval.d b/src/c/eval.d index 237f5466022349604d88d5d9a4f79e1248044b34..b7d34a6a1978bdc2b7d6811d310b18f254b20ff9 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -16,127 +16,6 @@ #include #include -cl_object * -_ecl_va_sp(cl_narg narg) -{ - return ECL_STACK_FRAME_PTR(ecl_process_env()->stack_frame) + narg; -} - -/* Calling conventions: - * Compiled C code calls lisp function supplying #args, and args. - * Linking function performs check_args, gets jmp_buf with _setjmp, then - * if cfun then stores C code address into function link location - * and transfers to jmp_buf at cf_self - * if cclosure then replaces #args with cc_env and calls cc_self - * otherwise, it emulates funcall. - */ - -cl_object -ecl_apply_from_stack_frame(cl_object frame, cl_object x) -{ - cl_object *sp = ECL_STACK_FRAME_PTR(frame); - cl_index narg = frame->frame.size; - cl_object fun = x; - cl_object ret; - frame->frame.env->stack_frame = frame; - AGAIN: - frame->frame.env->function = fun; - if (ecl_unlikely(fun == ECL_NIL)) - FEundefined_function(x); - switch (ecl_t_of(fun)) { - case t_cfunfixed: - if (ecl_unlikely(narg != (cl_index)fun->cfun.narg)) - FEwrong_num_arguments(fun); - ret = APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp); - break; - case t_cfun: - ret = APPLY(narg, fun->cfun.entry, sp); - break; - case t_cclosure: - ret = APPLY(narg, fun->cclosure.entry, sp); - break; - case t_instance: - switch (fun->instance.isgf) { - case ECL_STANDARD_DISPATCH: - case ECL_RESTRICTED_DISPATCH: - ret = _ecl_standard_dispatch(frame, fun); - break; - case ECL_USER_DISPATCH: - fun = fun->instance.slots[fun->instance.length - 1]; - goto AGAIN; - case ECL_READER_DISPATCH: - case ECL_WRITER_DISPATCH: - ret = APPLY(narg, fun->instance.entry, sp); - break; - default: - FEinvalid_function(fun); - } - break; - case t_symbol: - if (ecl_unlikely(!ECL_FBOUNDP(fun))) - FEundefined_function(fun); - fun = ECL_SYM_FUN(fun); - goto AGAIN; - case t_bytecodes: - ret = ecl_interpret(frame, ECL_NIL, fun); - break; - case t_bclosure: - ret = ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code); - break; - default: - FEinvalid_function(x); - } - frame->frame.env->stack_frame = NULL; /* for gc's sake */ - return ret; -} - -cl_objectfn -ecl_function_dispatch(cl_env_ptr env, cl_object x) -{ - cl_object fun = x; - if (ecl_unlikely(fun == ECL_NIL)) - FEundefined_function(x); - switch (ecl_t_of(fun)) { - case t_cfunfixed: - env->function = fun; - return fun->cfunfixed.entry; - case t_cfun: - env->function = fun; - return fun->cfun.entry; - case t_cclosure: - env->function = fun; - return fun->cclosure.entry; - case t_instance: - env->function = fun; - return fun->instance.entry; - case t_symbol: - fun = ECL_SYM_FUN(fun); - env->function = fun; - return fun->cfun.entry; - case t_bytecodes: - env->function = fun; - return fun->bytecodes.entry; - case t_bclosure: - env->function = fun; - return fun->bclosure.entry; - default: - FEinvalid_function(x); - } -} - -cl_object -cl_funcall(cl_narg narg, cl_object function, ...) -{ - cl_object output; - --narg; - { - ECL_STACK_FRAME_VARARGS_BEGIN(narg, function, frame); - output = ecl_apply_from_stack_frame(frame, function); - ECL_STACK_FRAME_VARARGS_END(frame); - } - return output; -} - @(defun apply (fun lastarg &rest args) @ { if (narg == 2 && ecl_t_of(lastarg) == t_frame) { diff --git a/src/c/ffi.d b/src/c/ffi.d index f6b3ff17ba0f7411524bfc5918d624cc51443c3a..44e4bd0a060133720e02be39b8fd1527d18c2229 100644 --- a/src/c/ffi.d +++ b/src/c/ffi.d @@ -13,6 +13,7 @@ #include #define ECL_INCLUDE_FFI_H #include +#include #include static const cl_object ecl_aet_to_ffi_table[ecl_aet_bc+1] = { @@ -904,7 +905,7 @@ prepare_cif(cl_env_ptr the_env, ffi_cif *cif, cl_object return_type, /* Push the newly allocated object onto the stack so that it * is reachable by the garbage collector */ if (ECL_CONS_CAR(args) != object) { - ECL_STACK_PUSH(the_env, object); + ecl_vms_push(the_env, object); } } args = ECL_CONS_CDR(args); @@ -937,12 +938,12 @@ prepare_cif(cl_env_ptr the_env, ffi_cif *cif, cl_object return_type, volatile cl_index sp; ffi_cif cif; @ { - sp = ECL_STACK_INDEX(the_env); + sp = ecl_vms_index(the_env); prepare_cif(the_env, &cif, return_type, arg_types, args, cc_type, NULL); ffi_call(&cif, cfun, the_env->ffi_values, (void **)the_env->ffi_values_ptrs); object = ecl_foreign_data_ref_elt(the_env->ffi_values, ecl_foreign_type_code(return_type)); - ECL_STACK_SET_INDEX(the_env, sp); + ecl_vms_unwind(the_env, sp); if (object != ECL_NIL) { @(return object); } else { @@ -1019,3 +1020,32 @@ si_free_ffi_closure(cl_object closure) @(return closure_object); } @) #endif /* HAVE_LIBFFI */ + +/* -- Module definition ------------------------------------------------------ */ +static cl_object +init_env_ffi(cl_env_ptr the_env) +{ +#ifdef HAVE_LIBFFI + the_env->ffi_args_limit = 0; + the_env->ffi_types = 0; + the_env->ffi_values = 0; + the_env->ffi_values_ptrs = 0; +#endif + return ECL_NIL; +} + +ecl_def_ct_base_string(str_ffi, "FFI", 3, static, const); + +static struct ecl_module module_ffi = { + .name = str_ffi, + .create = ecl_module_no_op, + .enable = ecl_module_no_op, + .init_env = init_env_ffi, + .init_cpu = ecl_module_no_op_cpu, + .free_cpu = ecl_module_no_op_cpu, + .free_env = ecl_module_no_op_env, + .disable = ecl_module_no_op, + .destroy = ecl_module_no_op +}; + +cl_object ecl_module_ffi = (cl_object)&module_ffi; diff --git a/src/c/ffi/backtrace.d b/src/c/ffi/backtrace.d index d1b72a3108303ae6d314cedf603a89fe9a42c45d..0384babae25076ed4693e24ac14384f5d897c368 100644 --- a/src/c/ffi/backtrace.d +++ b/src/c/ffi/backtrace.d @@ -24,56 +24,9 @@ # include #endif -/* Max number of frames dumped by _ecl_dump_c_backtrace */ -#define MAX_BACKTRACE_SIZE 128 /* Max length of symbols printed */ #define MAX_SYMBOL_LENGTH 256 -void -_ecl_dump_c_backtrace() -{ -#if defined(ECL_UNIX_BACKTRACE) || defined(ECL_WINDOWS_BACKTRACE) - { - void **pointers = malloc(sizeof(void*) * MAX_BACKTRACE_SIZE); -# if defined(ECL_UNIX_BACKTRACE) - int nframes = backtrace(pointers, MAX_BACKTRACE_SIZE); - char **names = backtrace_symbols(pointers, nframes); -# elif defined(ECL_WINDOWS_BACKTRACE) - HANDLE process = GetCurrentProcess(); - if (!SymInitialize(process, NULL, TRUE)) { - return; - } - int nframes = CaptureStackBackTrace(0, MAX_BACKTRACE_SIZE, pointers, NULL); - char buffer[sizeof(SYMBOL_INFO) + MAX_SYMBOL_LENGTH * sizeof(TCHAR)]; - PSYMBOL_INFO pSymbol = (PSYMBOL_INFO)buffer; - pSymbol->SizeOfStruct = sizeof(SYMBOL_INFO); - pSymbol->MaxNameLen = MAX_SYMBOL_LENGTH; -# endif - int i; - fprintf(stderr, "\n;;; ECL C Backtrace\n"); - for (i = 0; i < nframes; i++) { -# if defined(ECL_UNIX_BACKTRACE) - fprintf(stderr, ";;; %s\n", names[i]); -# elif defined(ECL_WINDOWS_BACKTRACE) - DWORD64 displacement; - if (SymFromAddr(process, (DWORD64) pointers[i], &displacement, pSymbol)) { - fprintf(stderr, ";;; (%s+0x%llx) [0x%p]\n", pSymbol->Name, displacement, pointers[i]); - } else { - fprintf(stderr, ";;; (unknown) [0x%p]\n", pointers[i]); - } -# endif - } - fflush(stderr); - free(pointers); -# if defined(ECL_UNIX_BACKTRACE) - free(names); -# elif defined(ECL_WINDOWS_BACKTRACE) - SymCleanup(process); -# endif - } -#endif /* defined(ECL_UNIX_BACKTRACE) || defined(ECL_WINDOWS_BACKTRACE) */ -} - cl_object si_dump_c_backtrace(cl_object size) { diff --git a/src/c/ffi/libraries.d b/src/c/ffi/libraries.d index 098cd483d41c32f2e93eccbf25f3f9276a424016..21441dfc0ce3929b3090269cef92224d73284a55 100644 --- a/src/c/ffi/libraries.d +++ b/src/c/ffi/libraries.d @@ -221,7 +221,7 @@ static cl_object ecl_library_find_by_name(cl_object filename) { cl_object l; - for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + for (l = ecl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { cl_object other = ECL_CONS_CAR(l); cl_object name = other->cblock.name; if (!Null(name) && ecl_string_eq(name, filename)) { @@ -235,7 +235,7 @@ static cl_object ecl_library_find_by_handle(void *handle) { cl_object l; - for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + for (l = ecl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { cl_object other = ECL_CONS_CAR(l); if (handle == other->cblock.handle) { return other; @@ -268,7 +268,7 @@ ecl_library_open_inner(cl_object filename, bool self_destruct) block->cblock.refs = ecl_one_plus(block->cblock.refs); } else { si_set_finalizer(block, ECL_T); - cl_core.libraries = CONS(block, cl_core.libraries); + ecl_core.libraries = CONS(block, ecl_core.libraries); } } ecl_enable_interrupts(); @@ -341,7 +341,7 @@ ecl_library_symbol(cl_object block, const char *symbol, bool lock) { void *p; if (block == @':default') { cl_object l; - for (l = cl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { + for (l = ecl_core.libraries; l != ECL_NIL; l = ECL_CONS_CDR(l)) { cl_object block = ECL_CONS_CAR(l); p = ecl_library_symbol(block, symbol, lock); if (p) return p; @@ -426,7 +426,7 @@ ecl_library_close(cl_object block) { block = ECL_NIL; } else if (block->cblock.handle != NULL) { success = GC_call_with_alloc_lock(dlclose_wrapper, block); - cl_core.libraries = ecl_remove_eq(block, cl_core.libraries); + ecl_core.libraries = ecl_remove_eq(block, ecl_core.libraries); } else { /* block not loaded */ success = FALSE; } @@ -443,8 +443,8 @@ ecl_library_close(cl_object block) { void ecl_library_close_all(void) { - while (cl_core.libraries != ECL_NIL) { - ecl_library_close(ECL_CONS_CAR(cl_core.libraries)); + while (ecl_core.libraries != ECL_NIL) { + ecl_library_close(ECL_CONS_CAR(ecl_core.libraries)); } } diff --git a/src/c/file.d b/src/c/file.d index 798b0a37faf690f372266ca8b4fadfe0dbf61421..03fa8841151fe1f06d26cb7c0eaef75969705e0f 100644 --- a/src/c/file.d +++ b/src/c/file.d @@ -5807,7 +5807,7 @@ ecl_open_stream(cl_object fn, enum ecl_smmode smm, cl_object if_exists, @(return strm); @) -@(defun close (strm &key (abort @'nil')) +@(defun close (strm &key (abort ECL_NIL)) @ @(return stream_dispatch_table(strm)->close(strm)); @) diff --git a/src/c/hash.d b/src/c/hash.d index d9c3320b49b6dca33ebce3a516be2aa5b7d95746..580f168944f1d9b750a93530950df09c8eb747e8 100644 --- a/src/c/hash.d +++ b/src/c/hash.d @@ -943,8 +943,8 @@ ecl_extend_hashtable(cl_object hashtable) (weakness ECL_NIL) (synchronized ECL_NIL) (size ecl_make_fixnum(1024)) - (rehash_size cl_core.rehash_size) - (rehash_threshold cl_core.rehash_threshold)) + (rehash_size ecl_ct_default_rehash_size) + (rehash_threshold ecl_ct_default_rehash_threshold)) @ { cl_object hash = cl__make_hash_table(test, size, rehash_size, rehash_threshold); if (hash->hash.test == ecl_htt_generic) { diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 8671f2487eb3f8d59282d9a34d83be230718183f..f8719d8795e09f47efb764e4bc938e4625543350 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -24,85 +24,91 @@ static void VEbad_lambda_too_many_args(cl_object bytecodes, cl_object frame) { - FEprogram_error("Too many arguments passed to " - "function ~A~&Argument list: ~S", - 2, bytecodes, cl_apply(2, @'list', frame)); + ecl_ferror(ECL_EX_VM_BADARG_EXCD, bytecodes, frame); } static void VEbad_lambda_unknown_keyword(cl_object bytecodes, cl_object frame) { - FEprogram_error("Unknown keyword argument passed to function ~S.~&" - "Argument list: ~S", 2, bytecodes, - cl_apply(2, @'list', frame)); + ecl_ferror(ECL_EX_VM_BADARG_UNKK, bytecodes, frame); } static void VEbad_lambda_odd_keys(cl_object bytecodes, cl_object frame) { - FEprogram_error("Function ~A called with odd number " - "of keyword arguments.", - 1, bytecodes); + ecl_ferror(ECL_EX_VM_BADARG_ODDK, bytecodes, frame); } static void VEwrong_arg_type_endp(cl_object reg0) { - FEwrong_type_only_arg(@[endp], reg0, @[list]); + ecl_ferror(ECL_EX_VM_BADARG_ENDP, ECL_NIL, reg0); } static void VEwrong_arg_type_car(cl_object reg0) { - FEwrong_type_only_arg(@[car], reg0, @[cons]); + ecl_ferror(ECL_EX_VM_BADARG_CAR, ECL_NIL, reg0); } static void VEwrong_arg_type_cdr(cl_object reg0) { - FEwrong_type_only_arg(@[cdr], reg0, @[cons]); + ecl_ferror(ECL_EX_VM_BADARG_CDR, ECL_NIL, reg0); } static void -VEwrong_arg_type_nth_val(cl_fixnum n) +VEwrong_arg_type_nth_val() { - FEerror("Wrong index passed to NTH-VAL", 1, ecl_make_fixnum(n)); + ecl_ferror(ECL_EX_VM_BADARG_NTH_VAL, ECL_NIL, ECL_NIL); +} + +static void +VEwrong_args_progv(cl_object vars, cl_object vals) +{ + ecl_ferror(ECL_EX_VM_BADARG_PROGV, vars, vals); } static void VEassignment_to_constant(cl_object var) { - FEassignment_to_constant(var); + ecl_ferror(ECL_EX_V_CSETQ, var, ECL_NIL); +} + +static void +VEbinding_a_constant(cl_object var) +{ + ecl_ferror(ECL_EX_V_CBIND, var, ECL_NIL); } static void VEunbound_variable(cl_object var) { - FEunbound_variable(var); + ecl_ferror(ECL_EX_V_UNBND, var, ECL_NIL); } static void -VEwrong_num_arguments(cl_object fname) +VEillegal_variable_name(cl_object name) { - FEwrong_num_arguments(fname); + ecl_ferror(ECL_EX_V_BNAME, name, ECL_NIL); } static void -VEundefined_function(cl_object fun) +VEwrong_num_arguments(cl_object fun) { - FEundefined_function(fun); + ecl_ferror(ECL_EX_F_NARGS, fun, ECL_NIL); } static void -VEinvalid_function(cl_object fun) +VEundefined_function(cl_object fun) { - FEinvalid_function(fun); + ecl_ferror(ECL_EX_F_UNDEF, fun, ECL_NIL); } static void -VEclose_around_arg_type() +VEinvalid_function(cl_object fun) { - FEerror("Internal error: ecl_close_around should be called on t_bytecodes or t_bclosure.", 0); + ecl_ferror(ECL_EX_F_INVAL, fun, ECL_NIL); } /* ------------------------------ LEXICAL ENV. ------------------------------ */ @@ -248,7 +254,7 @@ static cl_object close_around_self(cl_object fun) { cl_object v, template; if(ecl_t_of(fun) != t_bytecodes) - VEclose_around_arg_type(); + VEinvalid_function(fun); template = fun->bytecodes.flex; if(Null(template)) return fun; /* Make a closure */ @@ -286,7 +292,7 @@ close_around_self_fixup(cl_object fun, cl_object lcl_env, cl_object lex_env) { fun->bclosure.lex = new_lex; break; default: - VEclose_around_arg_type(); + VEinvalid_function(fun); } } @@ -296,7 +302,7 @@ ecl_close_around(cl_object fun, cl_object lcl_env, cl_object lex_env) { cl_object v, new_lex, template, entry; cl_fixnum nlex, idx, ndx; if(ecl_t_of(fun) != t_bytecodes) - VEclose_around_arg_type(); + VEinvalid_function(fun); template = fun->bytecodes.flex; if(Null(template)) return fun; /* Close around */ @@ -322,6 +328,32 @@ ecl_close_around(cl_object fun, cl_object lcl_env, cl_object lex_env) { return v; } +cl_index +ecl_progv(cl_env_ptr env, cl_object vars0, cl_object values0) +{ + cl_object vars = vars0, values = values0; + cl_index n = env->bds_stack.top - env->bds_stack.org; + for (; LISTP(vars) && LISTP(values); vars = ECL_CONS_CDR(vars)) { + if (Null(vars)) { + return n; + } else { + cl_object var = ECL_CONS_CAR(vars); + if (!ECL_SYMBOLP(var) || Null(var)) + VEillegal_variable_name(var); + if (var->symbol.stype & ecl_stp_constant) + VEbinding_a_constant(var); + if (Null(values)) { + ecl_bds_bind(env, var, OBJNULL); + } else { + ecl_bds_bind(env, var, ECL_CONS_CAR(values)); + values = ECL_CONS_CDR(values); + } + } + } + VEwrong_args_progv(vars0, values0); + _ecl_unexpected_return(); +} + static inline cl_object call_stepper(cl_env_ptr the_env, cl_object form, cl_object delta) { @@ -421,7 +453,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) Inlined forms for some functions which act on reg0 and stack. */ CASE(OP_CONS); { - cl_object car = ECL_STACK_POP_UNSAFE(the_env); + cl_object car = ecl_vms_popu(the_env); reg0 = CONS(car, reg0); THREAD_NEXT; } @@ -447,7 +479,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) cl_index n; GET_OPARG(n, vector); while (--n) { - reg0 = CONS(ECL_STACK_POP_UNSAFE(the_env), reg0); + reg0 = CONS(ecl_vms_popu(the_env), reg0); } THREAD_NEXT; } @@ -475,7 +507,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PINT); { cl_fixnum n; GET_OPARG(n, vector); - ECL_STACK_PUSH(the_env, ecl_make_fixnum(n)); + ecl_vms_push(the_env, ecl_make_fixnum(n)); THREAD_NEXT; } @@ -483,7 +515,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) Pushes the object in REG0. */ CASE(OP_PUSH); { - ECL_STACK_PUSH(the_env, reg0); + ecl_vms_push(the_env, reg0); THREAD_NEXT; } /* OP_PUSHV n{lcl} @@ -494,13 +526,13 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PUSHV); { int ndx; GET_OPARG(ndx, vector); - ECL_STACK_PUSH(the_env, ecl_lcl_env_get_var(lcl_env, ndx)); + ecl_vms_push(the_env, ecl_lcl_env_get_var(lcl_env, ndx)); THREAD_NEXT; } CASE(OP_PUSHVC); { int ndx; GET_OPARG(ndx, vector); - ECL_STACK_PUSH(the_env, ecl_lex_env_get_var(lex_env, ndx)); + ecl_vms_push(the_env, ecl_lex_env_get_var(lex_env, ndx)); THREAD_NEXT; } CASE(OP_PUSHVS); { @@ -509,7 +541,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) value = ECL_SYM_VAL(the_env, var_name); if (ecl_unlikely(value == OBJNULL)) VEunbound_variable(var_name); - ECL_STACK_PUSH(the_env, value); + ecl_vms_push(the_env, value); THREAD_NEXT; } /* OP_PUSHQ n{arg} @@ -518,7 +550,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PUSHQ); { cl_object aux; GET_DATA(aux, vector, data); - ECL_STACK_PUSH(the_env, aux); + ecl_vms_push(the_env, aux); THREAD_NEXT; } @@ -540,7 +572,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) the_env->function = ECL_SYM_FUN(s); f = ECL_SYM_FUN(s)->cfun.entry; SETUP_ENV(the_env); - reg0 = f(2, ECL_STACK_POP_UNSAFE(the_env), reg0); + reg0 = f(2, ecl_vms_popu(the_env), reg0); THREAD_NEXT; } @@ -574,7 +606,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) */ CASE(OP_FCALL); { GET_OPARG(narg, vector); - reg0 = ECL_STACK_REF(the_env,-narg-1); + reg0 = ECL_VMS_REF(the_env,-narg-1); INTERPRET_FUNCALL(reg0, the_env, frame_aux, narg, reg0); THREAD_NEXT; } @@ -584,8 +616,8 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) the stack (They all have been deposited by OP_PUSHVALUES) */ CASE(OP_MCALL); { - narg = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); - reg0 = ECL_STACK_REF(the_env,-narg-1); + narg = ecl_fixnum(ecl_vms_popu(the_env)); + reg0 = ECL_VMS_REF(the_env,-narg-1); INTERPRET_FUNCALL(reg0, the_env, frame_aux, narg, reg0); THREAD_NEXT; } @@ -594,14 +626,14 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) Pops a single value pushed by a OP_PUSH* operator. */ CASE(OP_POP); { - reg0 = ECL_STACK_POP_UNSAFE(the_env); + reg0 = ecl_vms_popu(the_env); THREAD_NEXT; } /* OP_POP1 Pops a single value pushed by a OP_PUSH* operator, ignoring it. */ CASE(OP_POP1); { - (void)ECL_STACK_POP_UNSAFE(the_env); + (void)ecl_vms_popu(the_env); THREAD_NEXT; } /* OP_POPREQ @@ -624,7 +656,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) if (frame_index >= frame->frame.size) { reg0 = ECL_NIL; } else { - ECL_STACK_PUSH(the_env, ECL_STACK_FRAME_REF(frame, frame_index++)); + ecl_vms_push(the_env, ECL_STACK_FRAME_REF(frame, frame_index++)); reg0 = ECL_T; } THREAD_NEXT; @@ -676,18 +708,18 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) } } } - if (flag != ECL_NIL) ECL_STACK_PUSH(the_env, value); - ECL_STACK_PUSH(the_env, flag); + if (flag != ECL_NIL) ecl_vms_push(the_env, value); + ecl_vms_push(the_env, flag); } if (count && Null(aok)) { cl_object *p = first; for (; p != last; ++p) { - if (*(p++) == @':allow-other-keys') { + if (*(p++) == ECL_ALLOW_OTHER_KEYS) { aok = *p; count -= 2; /* only the first :allow-other-keys argument is considered */ for (++p; p != last; ++p) { - if (*(p++) != @':allow-other-keys') + if (*(p++) != ECL_ALLOW_OTHER_KEYS) break; count -= 2; } @@ -859,7 +891,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) output values are left in VALUES(...). */ CASE(OP_THROW); { - cl_object tag_name = ECL_STACK_POP_UNSAFE(the_env); + cl_object tag_name = ecl_vms_popu(the_env); the_env->values[0] = reg0; cl_throw(tag_name); THREAD_NEXT; @@ -954,7 +986,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PBIND); { cl_object var_name; GET_DATA(var_name, vector, data); - bind_var(lcl_env, var_name, ECL_STACK_POP_UNSAFE(the_env)); + bind_var(lcl_env, var_name, ecl_vms_popu(the_env)); THREAD_NEXT; } CASE(OP_VBIND); { @@ -975,7 +1007,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PBINDS); { cl_object var_name; GET_DATA(var_name, vector, data); - ecl_bds_bind(the_env, var_name, ECL_STACK_POP_UNSAFE(the_env)); + ecl_bds_bind(the_env, var_name, ecl_vms_popu(the_env)); THREAD_NEXT; } CASE(OP_VBINDS); { @@ -1027,20 +1059,20 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PSETQ); { int ndx; GET_OPARG(ndx, vector); - ecl_lcl_env_set_var(lcl_env, ndx, ECL_STACK_POP_UNSAFE(the_env)); + ecl_lcl_env_set_var(lcl_env, ndx, ecl_vms_popu(the_env)); THREAD_NEXT; } CASE(OP_PSETQC); { int ndx; GET_OPARG(ndx, vector); - ecl_lex_env_set_var(lex_env, ndx, ECL_STACK_POP_UNSAFE(the_env)); + ecl_lex_env_set_var(lex_env, ndx, ecl_vms_popu(the_env)); THREAD_NEXT; } CASE(OP_PSETQS); { cl_object var; GET_DATA(var, vector, data); /* INV: Not NIL, and of type t_symbol */ - ECL_SETQ(the_env, var, ECL_STACK_POP_UNSAFE(the_env)); + ECL_SETQ(the_env, var, ecl_vms_popu(the_env)); THREAD_NEXT; } CASE(OP_VSETQ); { @@ -1089,13 +1121,13 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_BLOCK); { GET_DATA(reg0, vector, data); - reg1 = ecl_make_fixnum(the_env->frame_id++); + reg1 = ecl_make_fixnum(the_env->frs_stack.frame_id++); bind_frame(lcl_env, reg1, reg0); THREAD_NEXT; } CASE(OP_DO); { reg0 = ECL_NIL; - reg1 = ecl_make_fixnum(the_env->frame_id++); + reg1 = ecl_make_fixnum(the_env->frs_stack.frame_id++); bind_frame(lcl_env, reg1, reg0); THREAD_NEXT; } @@ -1107,14 +1139,14 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_FRAME); { cl_opcode *exit; GET_LABEL(exit, vector); - ECL_STACK_PUSH(the_env, tangle_lcl(lcl_env)); - ECL_STACK_PUSH(the_env, (cl_object)exit); + ecl_vms_push(the_env, tangle_lcl(lcl_env)); + ecl_vms_push(the_env, (cl_object)exit); ecl_frs_push(the_env,reg1); if (__ecl_frs_push_result != 0) { reg0 = the_env->values[0]; - vector = (cl_opcode *)ECL_STACK_REF(the_env,-1); /* FIXME! */ + vector = (cl_opcode *)ECL_VMS_REF(the_env,-1); /* FIXME! */ /* Unbind locals including the frame, we are leaving the frame. */ - unwind_lcl(lcl_env, ECL_STACK_REF(the_env, -2)); + unwind_lcl(lcl_env, ECL_VMS_REF(the_env,-2)); unbind_lcl(lcl_env, 1); /* unbind the frame */ goto DO_EXIT_FRAME; } @@ -1136,17 +1168,17 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_TAGBODY); { int n; GET_OPARG(n, vector); - ECL_STACK_PUSH(the_env, tangle_lcl(lcl_env)); - ECL_STACK_PUSH(the_env, (cl_object)vector); /* FIXME! */ + ecl_vms_push(the_env, tangle_lcl(lcl_env)); + ecl_vms_push(the_env, (cl_object)vector); /* FIXME! */ vector += n * OPARG_SIZE; ecl_frs_push(the_env,reg1); if (__ecl_frs_push_result != 0) { /* Wait here for gotos. Each goto sets VALUES(0) to an integer which ranges from 0 to ntags-1, depending on the tag. These numbers are indices into the jump table and are computed at compile time. */ - cl_opcode *table = (cl_opcode *)ECL_STACK_REF(the_env,-1); + cl_opcode *table = (cl_opcode *)ECL_VMS_REF(the_env,-1); /* Unbind locals but leave the frame, we are still inside the frame. */ - unwind_lcl(lcl_env, ECL_STACK_REF(the_env,-2)); + unwind_lcl(lcl_env, ECL_VMS_REF(the_env,-2)); table = table + ecl_fixnum(the_env->values[0]) * OPARG_SIZE; vector = table + *(cl_oparg *)table; } @@ -1158,7 +1190,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_EXIT_FRAME); { DO_EXIT_FRAME: ecl_frs_pop(the_env); - ECL_STACK_POP_N_UNSAFE(the_env, 2); + ecl_vms_drop(the_env, 2); THREAD_NEXT; } CASE(OP_NIL); { @@ -1166,7 +1198,7 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) THREAD_NEXT; } CASE(OP_PUSHNIL); { - ECL_STACK_PUSH(the_env, ECL_NIL); + ecl_vms_push(the_env, ECL_NIL); THREAD_NEXT; } CASE(OP_VALUEREG0); { @@ -1181,22 +1213,22 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) PUSH_VALUES: CASE(OP_PUSHVALUES); { cl_index i = the_env->nvalues; - ECL_STACK_PUSH_N(the_env, i+1); + ecl_vms_grow(the_env, i+1); the_env->values[0] = reg0; - memcpy(&ECL_STACK_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); - ECL_STACK_REF(the_env, -1) = ecl_make_fixnum(the_env->nvalues); + memcpy(&ECL_VMS_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); + ECL_VMS_REF(the_env, -1) = ecl_make_fixnum(the_env->nvalues); THREAD_NEXT; } /* OP_PUSHMOREVALUES Adds more values to the ones pushed by OP_PUSHVALUES. */ CASE(OP_PUSHMOREVALUES); { - cl_index n = ecl_fixnum(ECL_STACK_REF(the_env,-1)); + cl_index n = ecl_fixnum(ECL_VMS_REF(the_env,-1)); cl_index i = the_env->nvalues; - ECL_STACK_PUSH_N(the_env, i); + ecl_vms_grow(the_env, i); the_env->values[0] = reg0; - memcpy(&ECL_STACK_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); - ECL_STACK_REF(the_env, -1) = ecl_make_fixnum(n + i); + memcpy(&ECL_VMS_REF(the_env, -(i+1)), the_env->values, i * sizeof(cl_object)); + ECL_VMS_REF(the_env, -1) = ecl_make_fixnum(n + i); THREAD_NEXT; } /* OP_POPVALUES @@ -1204,16 +1236,16 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) */ CASE(OP_POPVALUES); { cl_object *dest = the_env->values; - int n = the_env->nvalues = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + int n = the_env->nvalues = ecl_fixnum(ecl_vms_popu(the_env)); if (n == 0) { *dest = reg0 = ECL_NIL; THREAD_NEXT; } else if (n == 1) { - *dest = reg0 = ECL_STACK_POP_UNSAFE(the_env); + *dest = reg0 = ecl_vms_popu(the_env); THREAD_NEXT; } else { - ECL_STACK_POP_N_UNSAFE(the_env,n); - memcpy(dest, &ECL_STACK_REF(the_env,0), n * sizeof(cl_object)); + ecl_vms_drop(the_env,n); + memcpy(dest, &ECL_VMS_REF(the_env,0), n * sizeof(cl_object)); reg0 = *dest; THREAD_NEXT; } @@ -1226,8 +1258,8 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) cl_fixnum n; GET_OPARG(n, vector); the_env->nvalues = n; - ECL_STACK_POP_N_UNSAFE(the_env, n); - memcpy(the_env->values, &ECL_STACK_REF(the_env, 0), n * sizeof(cl_object)); + ecl_vms_drop(the_env, n); + memcpy(the_env->values, &ECL_VMS_REF(the_env, 0), n * sizeof(cl_object)); reg0 = the_env->values[0]; THREAD_NEXT; } @@ -1236,9 +1268,9 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) The index N-th is extracted from the top of the stack. */ CASE(OP_NTHVAL); { - cl_fixnum n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + cl_fixnum n = ecl_fixnum(ecl_vms_popu(the_env)); if (ecl_unlikely(n < 0)) { - VEwrong_arg_type_nth_val(n); + VEwrong_arg_type_nth_val(); } else if ((cl_index)n >= the_env->nvalues) { reg0 = ECL_NIL; } else if (n) { @@ -1262,35 +1294,35 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) CASE(OP_PROTECT); { cl_opcode *exit; GET_LABEL(exit, vector); - ECL_STACK_PUSH(the_env, tangle_lcl(lcl_env)); - ECL_STACK_PUSH(the_env, (cl_object)exit); + ecl_vms_push(the_env, tangle_lcl(lcl_env)); + ecl_vms_push(the_env, (cl_object)exit); ecl_frs_push(the_env,ECL_PROTECT_TAG); if (__ecl_frs_push_result != 0) { ecl_frs_pop(the_env); - vector = (cl_opcode *)ECL_STACK_POP_UNSAFE(the_env); - unwind_lcl(lcl_env, ECL_STACK_POP_UNSAFE(the_env)); + vector = (cl_opcode *)ecl_vms_popu(the_env); + unwind_lcl(lcl_env, ecl_vms_popu(the_env)); reg0 = the_env->values[0]; - ECL_STACK_PUSH(the_env, ecl_make_fixnum(the_env->nlj_fr - the_env->frs_top)); + ecl_vms_push(the_env, ecl_make_fixnum(the_env->frs_stack.nlj_fr - the_env->frs_stack.top)); goto PUSH_VALUES; } THREAD_NEXT; } CASE(OP_PROTECT_NORMAL); { - ecl_bds_unwind(the_env, the_env->frs_top->frs_bds_top_index); + ecl_bds_unwind(the_env, the_env->frs_stack.top->frs_bds_ndx); ecl_frs_pop(the_env); - (void)ECL_STACK_POP_UNSAFE(the_env); - unwind_lcl(lcl_env, ECL_STACK_POP_UNSAFE(the_env)); - ECL_STACK_PUSH(the_env, ecl_make_fixnum(1)); + (void)ecl_vms_popu(the_env); + unwind_lcl(lcl_env, ecl_vms_popu(the_env)); + ecl_vms_push(the_env, ecl_make_fixnum(1)); goto PUSH_VALUES; } CASE(OP_PROTECT_EXIT); { - volatile cl_fixnum n = the_env->nvalues = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + volatile cl_fixnum n = the_env->nvalues = ecl_fixnum(ecl_vms_popu(the_env)); while (n--) - the_env->values[n] = ECL_STACK_POP_UNSAFE(the_env); + the_env->values[n] = ecl_vms_popu(the_env); reg0 = the_env->values[0]; - n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + n = ecl_fixnum(ecl_vms_popu(the_env)); if (n <= 0) - ecl_unwind(the_env, the_env->frs_top + n); + ecl_unwind(the_env, the_env->frs_stack.top + n); THREAD_NEXT; } @@ -1302,13 +1334,13 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) */ CASE(OP_PROGV); { cl_object values = reg0; - cl_object vars = ECL_STACK_POP_UNSAFE(the_env); + cl_object vars = ecl_vms_popu(the_env); cl_index n = ecl_progv(the_env, vars, values); - ECL_STACK_PUSH(the_env, ecl_make_fixnum(n)); + ecl_vms_push(the_env, ecl_make_fixnum(n)); THREAD_NEXT; } CASE(OP_EXIT_PROGV); { - cl_index n = ecl_fixnum(ECL_STACK_POP_UNSAFE(the_env)); + cl_index n = ecl_fixnum(ecl_vms_popu(the_env)); ecl_bds_unwind(the_env, n); THREAD_NEXT; } @@ -1325,9 +1357,9 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) GET_DATA(form, vector, data); SETUP_ENV(the_env); the_env->values[0] = reg0; - n = ecl_stack_push_values(the_env); + n = ecl_vms_push_values(the_env); call_stepper(the_env, form, ecl_make_fixnum(1)); - ecl_stack_pop_values(the_env, n); + ecl_vms_pop_values(the_env, n); reg0 = the_env->values[0]; THREAD_NEXT; } @@ -1345,9 +1377,9 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes) cl_index n; SETUP_ENV(the_env); the_env->values[0] = reg0; - n = ecl_stack_push_values(the_env); + n = ecl_vms_push_values(the_env); call_stepper(the_env, ECL_NIL, ecl_make_fixnum(-1)); - ecl_stack_pop_values(the_env, n); + ecl_vms_pop_values(the_env, n); reg0 = the_env->values[0]; THREAD_NEXT; } diff --git a/src/c/jump.d b/src/c/jump.d new file mode 100644 index 0000000000000000000000000000000000000000..bfd5a705804df9235e3f4d48bc1b1d1f74fe569d --- /dev/null +++ b/src/c/jump.d @@ -0,0 +1,307 @@ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ + +/* control.c - signaling conditions and transfering program control */ + +#include +#include +#include +#include +#include + +#include +#include +#include +#include +#include +#if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) +# include +#endif + +#if defined(HAVE_BACKTRACE) && defined(HAVE_BACKTRACE_SYMBOLS) +# include +# define ECL_UNIX_BACKTRACE +#endif + +#if defined(ECL_WINDOWS_BACKTRACE) +# include +# include +#endif + +/* -- Escapes --------------------------------------------------------------- ** + +Non-local transfer of control. Practically this is like THROW, where +continuation is the exit point estabilished by an equivalent of CATCH. + +** -------------------------------------------------------------------------- */ + +void +ecl_escape(cl_object continuation) +{ + ecl_frame_ptr fr = frs_sch(continuation); + if (!fr) { + ecl_ferror(ECL_EX_S_FMISS, continuation, ECL_NIL); + } + ecl_unwind(ecl_process_env(), fr); + _ecl_unexpected_return(); +} + +void +ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr) +{ + env->frs_stack.nlj_fr = fr; + ecl_frame_ptr top = env->frs_stack.top; + while (top != fr && top->frs_val != ECL_PROTECT_TAG){ + top->frs_val = ECL_DUMMY_TAG; + --top; + } + env->ihs_stack.top = top->frs_ihs; + ecl_bds_unwind(env, top->frs_bds_ndx); + ecl_vms_unwind(env, top->frs_vms_ndx); + env->frs_stack.top = top; + ecl_longjmp(env->frs_stack.top->frs_jmpbuf, 1); + _ecl_unexpected_return(); +} + +void +cl_throw(cl_object tag) +{ + ecl_escape(tag); +} + +void +cl_return_from(cl_object block_id, cl_object block_name) +{ + ecl_escape(block_id); +} + +void +cl_go(cl_object tag_id, cl_object label) +{ + + const cl_env_ptr the_env = ecl_process_env(); + the_env->values[0] = label; + the_env->nvalues = 1; + ecl_escape(tag_id); +} + +/* -- Signaling conditions -------------------------------------------------- ** + +Low level signals work slightly different from Common Lisp. There are no handler +clusters nor restarts. %signal is called with three arguments: + +- condition :: the signaled object (may be any cl_object) +- returns :: the flag stating whether whether the function returns +- destination :: the thread the condition is delivered to (implementme!) + +The signal invokes all handlers bound with with-handler in LIFO order and call +them with the condition. The handler may take do one of the following: + +- decline :: return, then signal proceeds to the next handler +- escape :: perform non-local transfer of control +- defer :: signal a condition, invoke a debugger, ... + +The called handler is not bound as an active signal handler during its execution +to avoid an infinite recursion while resignaling. When all handlers decline and +the CONTINUABLE is ECL_NIL, then we abort the program by invoking the function +_ecl_unexpected_return(). + +** -------------------------------------------------------------------------- */ + +cl_object +ecl_signal(cl_object condition, cl_object returns, cl_object thread) { + const cl_env_ptr the_env = ecl_process_env(); + cl_object symbol, cluster, handler; + symbol = ECL_SIGNAL_HANDLERS; + cluster = ECL_SYM_VAL(the_env, symbol); + ecl_bds_bind(the_env, symbol, cluster); + while(!Null(cluster)) { + handler = ECL_CONS_CAR(cluster); + cluster = ECL_CONS_CDR(cluster); + ECL_SETQ(the_env, symbol, cluster); + _ecl_funcall2(handler, condition); + } + if (returns == ECL_NIL) + _ecl_unexpected_return(); + ecl_bds_unwind1(the_env); + return ECL_NIL; +} + +cl_object +ecl_call_with_handler(cl_object handler, cl_object continuation) +{ + cl_env_ptr the_env = ecl_process_env(); + cl_object result; + ECL_WITH_HANDLER_BEGIN(the_env, handler) { + result = _ecl_funcall1(continuation); + } ECL_WITH_HANDLER_END; + return result; +} + +/* -- Exceptions ------------------------------------------------------------ ** + +Conditions in Common Lisp are instances of STANDARD-CLASS. While eventually I'd +like to include classes to the early environment, that would be too much work at +one go. This is also the reason why ecl_signal accepts all kinds of objects. + +In order to signal conditions in the early environment we use a trick: we pass +to ecl_signal objects of type ecl_exception that are recognized by a Common Lisp +handler, and that handler resignals proper conditions. Exceptions are allocated +on the stack and capturing them is prohibited. + +ecl_raise is very similar to ecl_signal with an exception that it does not pop +the current handler from the stack. This is to ensure, that the condition +handler is invoked despite being "above" the exception handler on the stack. To +avoid infinite recursion it is prohibited to resignal the exception itself. + +** ---------------------------------------------------------------------------*/ + +cl_object +ecl_raise(ecl_ex_type type, bool returns, + cl_object arg1, cl_object arg2, cl_object arg3, void *arg4) +{ + const cl_env_ptr the_env = ecl_process_env(); + struct ecl_exception ex = + { .t = t_exception, .ex_type = type, + .arg1 = arg1, .arg2 = arg2, .arg3 = arg3, .arg4 = arg4 }; + cl_object symbol, cluster, handler; + cl_object exception = ecl_cast_ptr(cl_object,&ex); + symbol = ECL_SIGNAL_HANDLERS; + cluster = ECL_SYM_VAL(the_env, symbol); + ecl_bds_bind(the_env, symbol, cluster); + while(!Null(cluster)) { + handler = ECL_CONS_CAR(cluster); + cluster = ECL_CONS_CDR(cluster); + _ecl_funcall2(handler, exception); + } + if (!returns) + _ecl_unexpected_return(); + ecl_bds_unwind1(the_env); + return ECL_NIL; +} + +cl_object +ecl_ferror(ecl_ex_type extype, cl_object type, cl_object args) +{ + ecl_raise(extype, 0, type, args, ECL_NIL, NULL); + _ecl_unexpected_return(); +} + +cl_object +ecl_cerror(ecl_ex_type extype, cl_object type, cl_object args) +{ + ecl_raise(extype, 1, type, args, ECL_NIL, NULL); + return ECL_NIL; +} + +/* -- Fatal errors ---------------------------------------------------------- ** + +Fatal errors that can't be recovered from and result in the program abortion. + +** ---------------------------------------------------------------------------*/ + +void +ecl_internal_error(const char *s) +{ + int saved_errno = errno; + fprintf(stderr, "\nInternal or unrecoverable error in:\n%s\n", s); + if (saved_errno) { + fprintf(stderr, " [%d: %s]\n", saved_errno, strerror(saved_errno)); + } + fflush(stderr); + _ecl_dump_c_backtrace(); +#ifdef SIGIOT + signal(SIGIOT, SIG_DFL); /* avoid getting into a loop with abort */ +#endif + abort(); +} + +#ifdef ECL_THREADS +void +ecl_thread_internal_error(const char *s) +{ + int saved_errno = errno; + fprintf(stderr, "\nInternal thread error in:\n%s\n", s); + if (saved_errno) { + fprintf(stderr, " [%d: %s]\n", saved_errno, strerror(saved_errno)); + } + _ecl_dump_c_backtrace(); + fprintf(stderr, "\nDid you forget to call `ecl_import_current_thread'?\n" + "Exitting thread.\n"); + fflush(stderr); + ecl_thread_exit(); + _ecl_unexpected_return(); +} +#endif + +void +_ecl_unexpected_return() +{ + ecl_internal_error("*** \n" + "*** A call to ERROR returned without handling the error.\n" + "*** This should have never happened and is usually a signal\n" + "*** that the debugger or the universal error handler were\n" + "*** improperly coded or altered. Please contact the maintainers\n" + "*** \n"); +} + +void +ecl_miscompilation_error() +{ + ecl_internal_error("*** \n" + "*** Encountered a code path that should have never been taken.\n" + "*** This likely indicates a bug in the ECL compiler. Please contact\n" + "*** the maintainers.\n" + "*** \n"); +} + + +/* Max number of frames dumped by _ecl_dump_c_backtrace */ +#define MAX_BACKTRACE_SIZE 128 +/* Max length of symbols printed */ +#define MAX_SYMBOL_LENGTH 256 + +void +_ecl_dump_c_backtrace() +{ +#if defined(ECL_UNIX_BACKTRACE) || defined(ECL_WINDOWS_BACKTRACE) + { + void **pointers = malloc(sizeof(void*) * MAX_BACKTRACE_SIZE); +# if defined(ECL_UNIX_BACKTRACE) + int nframes = backtrace(pointers, MAX_BACKTRACE_SIZE); + char **names = backtrace_symbols(pointers, nframes); +# elif defined(ECL_WINDOWS_BACKTRACE) + HANDLE process = GetCurrentProcess(); + if (!SymInitialize(process, NULL, TRUE)) { + return; + } + int nframes = CaptureStackBackTrace(0, MAX_BACKTRACE_SIZE, pointers, NULL); + char buffer[sizeof(SYMBOL_INFO) + MAX_SYMBOL_LENGTH * sizeof(TCHAR)]; + PSYMBOL_INFO pSymbol = (PSYMBOL_INFO)buffer; + pSymbol->SizeOfStruct = sizeof(SYMBOL_INFO); + pSymbol->MaxNameLen = MAX_SYMBOL_LENGTH; +# endif + int i; + fprintf(stderr, "\n;;; ECL C Backtrace\n"); + for (i = 0; i < nframes; i++) { +# if defined(ECL_UNIX_BACKTRACE) + fprintf(stderr, ";;; %s\n", names[i]); +# elif defined(ECL_WINDOWS_BACKTRACE) + DWORD64 displacement; + if (SymFromAddr(process, (DWORD64) pointers[i], &displacement, pSymbol)) { + fprintf(stderr, ";;; (%s+0x%llx) [0x%p]\n", pSymbol->Name, displacement, pointers[i]); + } else { + fprintf(stderr, ";;; (unknown) [0x%p]\n", pointers[i]); + } +# endif + } + fflush(stderr); + free(pointers); +# if defined(ECL_UNIX_BACKTRACE) + free(names); +# elif defined(ECL_WINDOWS_BACKTRACE) + SymCleanup(process); +# endif + } +#endif /* defined(ECL_UNIX_BACKTRACE) || defined(ECL_WINDOWS_BACKTRACE) */ +} diff --git a/src/c/main.d b/src/c/main.d index f2bedeb2246a967608e38d8e3334650d29096e5c..c457bb99f97fb3b75eac1fe5b2425c734bb0bd67 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -12,29 +12,10 @@ * */ -/******************************** IMPORTS *****************************/ +/* -- Imports ------------------------------------------------------- */ #include #include -#if defined(ECL_MS_WINDOWS_HOST) -# include -# include -# define MAXPATHLEN 512 -#endif -#ifndef MAXPATHLEN -# ifdef PATH_MAX -# define MAXPATHLEN PATH_MAX -# else -# define NO_PATH_MAX -# include -# endif -#endif -#ifdef ECL_USE_MPROTECT -# include -# ifndef MAP_FAILED -# define MAP_FAILED -1 -# endif -#endif #include #include #include @@ -42,254 +23,14 @@ #include #include - #include "ecl_features.h" #include "iso_latin_names.h" -/******************************* EXPORTS ******************************/ +/* -- Global Initialization ----------------------------------------- */ const char *ecl_self; -static struct cl_env_struct first_env; - -/************************ GLOBAL INITIALIZATION ***********************/ - - -/* HEAP */ - -#if ECL_FIXNUM_BITS <= 32 -/* 1GB */ -#define HEAP_SIZE_DEFAULT 1073741824L -#else -/* 4GB */ -#define HEAP_SIZE_DEFAULT 4294967296L -#endif - - static int ARGC; static char **ARGV; -/* INV: see ecl_option enum in external.h */ -cl_fixnum ecl_option_values[ECL_OPT_LIMIT+1] = { -#ifdef GBC_BOEHM_GENGC - 1, /* ECL_OPT_INCREMENTAL_GC */ -#else - 0, /* ECL_OPT_INCREMENTAL_GC */ -#endif - 1, /* ECL_OPT_TRAP_SIGSEGV */ - 1, /* ECL_OPT_TRAP_SIGFPE */ - 1, /* ECL_OPT_TRAP_SIGINT */ - 1, /* ECL_OPT_TRAP_SIGILL */ - 1, /* ECL_OPT_TRAP_SIGBUS */ - 1, /* ECL_OPT_TRAP_SIGPIPE */ - 1, /* ECL_OPT_TRAP_INTERRUPT_SIGNAL */ -#if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK) - 1, /* ECL_OPT_SIGNAL_HANDLING_THREAD */ -#else - 0, /* ECL_OPT_SIGNAL_HANDLING_THREAD */ -#endif - 16, /* ECL_OPT_SIGNAL_QUEUE_SIZE */ - 0, /* ECL_OPT_BOOTED */ - 8192, /* ECL_OPT_BIND_STACK_SIZE */ - 1024, /* ECL_OPT_BIND_STACK_SAFETY_AREA */ - 2048, /* ECL_OPT_FRAME_STACK_SIZE */ - 128, /* ECL_OPT_FRAME_STACK_SAFETY_AREA */ - 32768, /* ECL_OPT_LISP_STACK_SIZE */ - 128, /* ECL_OPT_LISP_STACK_SAFETY_AREA */ - ECL_DEFAULT_C_STACK_SIZE, /* ECL_OPT_C_STACK_SIZE */ - 4*sizeof(cl_index)*1024, /* ECL_OPT_C_STACK_SAFETY_AREA */ - HEAP_SIZE_DEFAULT, /* ECL_OPT_HEAP_SIZE */ - 1024*1024, /* ECL_OPT_HEAP_SAFETY_AREA */ - 0, /* ECL_OPT_THREAD_INTERRUPT_SIGNAL */ - 1, /* ECL_OPT_SET_GMP_MEMORY_FUNCTIONS */ - 1, /* ECL_OPT_USE_SETMODE_ON_FILES */ - 0}; - -#if !defined(GBC_BOEHM) -static char stdin_buf[BUFSIZ]; -static char stdout_buf[BUFSIZ]; -#endif - -cl_fixnum -ecl_get_option(int option) -{ - if (option >= ECL_OPT_LIMIT || option < 0) { - FEerror("Invalid boot option ~D", 1, ecl_make_fixnum(option)); - } - return ecl_option_values[option]; -} - -void -ecl_set_option(int option, cl_fixnum value) -{ - if (option > ECL_OPT_LIMIT || option < 0) { - FEerror("Invalid boot option ~D", 1, ecl_make_fixnum(option)); - } else { - if (option < ECL_OPT_BOOTED && - ecl_option_values[ECL_OPT_BOOTED]) { - FEerror("Cannot change option ~D while ECL is running", - 1, ecl_make_fixnum(option)); - } - ecl_option_values[option] = value; - } -} - -static void -init_env_mp(cl_env_ptr env) -{ -#if defined(ECL_THREADS) - env->cleanup = 0; -#else - env->own_process = ECL_NIL; -#endif -} - -static void -init_env_int(cl_env_ptr env) -{ - env->interrupt_struct = ecl_alloc(sizeof(*env->interrupt_struct)); - env->interrupt_struct->pending_interrupt = ECL_NIL; -#ifdef ECL_THREADS - ecl_mutex_init(&env->interrupt_struct->signal_queue_lock, FALSE); -#endif - { - int size = ecl_option_values[ECL_OPT_SIGNAL_QUEUE_SIZE]; - env->interrupt_struct->signal_queue = cl_make_list(1, ecl_make_fixnum(size)); - } - env->fault_address = env; - env->trap_fpe_bits = 0; -} - -static void -init_env_ffi(cl_env_ptr env) -{ -#ifdef HAVE_LIBFFI - env->ffi_args_limit = 0; - env->ffi_types = 0; - env->ffi_values = 0; - env->ffi_values_ptrs = 0; -#endif -} - -static void -init_env_aux(cl_env_ptr env) -{ - /* Reader */ - env->string_pool = ECL_NIL; - env->packages_to_be_created = ECL_NIL; - env->packages_to_be_created_p = ECL_NIL; - /* Format (written in C) */ -#if !defined(ECL_CMU_FORMAT) - env->fmt_aux_stream = ecl_make_string_output_stream(64, 1); -#endif - /* Bignum arithmetic */ - ecl_init_bignum_registers(env); - /* Bytecodes compiler environment */ - env->c_env = NULL; - /* CLOS caches */ - env->method_cache = ecl_make_cache(64, 4096); - env->slot_cache = ecl_make_cache(3, 4096); -} - -void -ecl_init_first_env(cl_env_ptr env) -{ -#ifdef ECL_THREADS - init_threads(); -#endif -#ifdef ECL_THREADS - env->bindings_array = si_make_vector(ECL_T, ecl_make_fixnum(1024), - ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL); - si_fill_array_with_elt(env->bindings_array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); - env->thread_local_bindings_size = env->bindings_array->vector.dim; - env->thread_local_bindings = env->bindings_array->vector.self.t; -#endif - init_env_mp(env); - init_env_int(env); - init_env_aux(env); - init_env_ffi(env); - init_stacks(env); -} - -void -ecl_init_env(cl_env_ptr env) -{ - init_env_mp(env); - init_env_int(env); - init_env_aux(env); - init_env_ffi(env); - init_stacks(env); -} - -void -_ecl_dealloc_env(cl_env_ptr env) -{ - /* Environment cleanup. This is required becauyse the environment is allocated - * using mmap or some other method. We could do more cleaning here.*/ -#ifdef ECL_THREADS - ecl_mutex_destroy(&env->interrupt_struct->signal_queue_lock); -#endif -#if defined(ECL_USE_MPROTECT) - if (munmap(env, sizeof(*env))) - ecl_internal_error("Unable to deallocate environment structure."); -#elif defined(ECL_USE_GUARD_PAGE) - if (!VirtualFree(env, 0, MEM_RELEASE)) - ecl_internal_error("Unable to deallocate environment structure."); -#else - ecl_free_unsafe(env); -#endif -} - -cl_env_ptr -_ecl_alloc_env(cl_env_ptr parent) -{ - /* - * Allocates the lisp environment for a thread. Depending on which - * mechanism we use for detecting delayed signals, we may allocate - * the environment using mmap or the garbage collector. - * - * Note that at this point we are not allocating any other memory - * which is stored via a pointer in the environment. If we would do - * that, an unlucky interrupt by the gc before the allocated - * environment is registered in cl_core.processes could lead to - * memory being freed because the gc is not aware of the pointer to - * the allocated memory in the environment. - */ - cl_env_ptr output; -#if defined(ECL_USE_MPROTECT) - output = (cl_env_ptr) mmap(0, sizeof(*output), PROT_READ | PROT_WRITE, - MAP_ANON | MAP_PRIVATE, -1, 0); - if (output == MAP_FAILED) - ecl_internal_error("Unable to allocate environment structure."); -#else -# if defined(ECL_USE_GUARD_PAGE) - output = VirtualAlloc(0, sizeof(*output), MEM_COMMIT, PAGE_READWRITE); - if (output == NULL) - ecl_internal_error("Unable to allocate environment structure."); -# else - output = ecl_malloc(sizeof(*output)); - if (output == NULL) - ecl_internal_error("Unable to allocate environment structure."); -# endif -#endif - { - size_t bytes = cl_core.default_sigmask_bytes; - if (bytes == 0) { - output->default_sigmask = 0; - } else if (parent) { - output->default_sigmask = ecl_alloc_atomic(bytes); - memcpy(output->default_sigmask, parent->default_sigmask, bytes); - } else { - output->default_sigmask = cl_core.default_sigmask; - } - } - output->method_cache = output->slot_cache = NULL; - output->interrupt_struct = NULL; - /* - * An uninitialized environment _always_ disables interrupts. They - * are activated later on by the thread entry point or init_unixint(). - */ - output->disable_interrupts = 1; - return output; -} void cl_shutdown(void) @@ -310,11 +51,9 @@ cl_shutdown(void) ecl_tcp_close_all(); #endif } - ecl_set_option(ECL_OPT_BOOTED, -1); + ecl_halt(); } -ecl_def_ct_single_float(default_rehash_size,1.5f,static,const); -ecl_def_ct_single_float(default_rehash_threshold,0.75f,static,const); ecl_def_ct_base_string(str_common_lisp,"COMMON-LISP",11,static,const); ecl_def_ct_base_string(str_common_lisp_user,"COMMON-LISP-USER",16,static,const); ecl_def_ct_base_string(str_cl,"CL",2,static,const); @@ -337,7 +76,6 @@ ecl_def_ct_base_string(str_gray,"GRAY",4,static,const); #endif ecl_def_ct_base_string(str_star_dot_star,"*.*",3,static,const); ecl_def_ct_base_string(str_rel_star_dot_star,"./*.*",5,static,const); -ecl_def_ct_base_string(str_empty,"",0,static,const); ecl_def_ct_base_string(str_G,"G",1,static,const); ecl_def_ct_base_string(str_T,"T",1,static,const); #ifdef ENABLE_DLOPEN @@ -352,22 +90,6 @@ ecl_def_ct_base_string(str_lsp,"lsp",3,static,const); ecl_def_ct_base_string(str_LSP,"LSP",3,static,const); ecl_def_ct_base_string(str_lisp,"lisp",4,static,const); ecl_def_ct_base_string(str_NIL,"NIL",3,static,const); -ecl_def_ct_base_string(str_slash,"/",1,static,const); - -ecl_def_ct_single_float(flt_zero,0,static,const); -ecl_def_ct_single_float(flt_zero_neg,-0.0,static,const); -ecl_def_ct_double_float(dbl_zero,0,static,const); -ecl_def_ct_double_float(dbl_zero_neg,-0.0,static,const); -ecl_def_ct_long_float(ldbl_zero,0,static,const); -ecl_def_ct_long_float(ldbl_zero_neg,-0.0l,static,const); -ecl_def_ct_ratio(plus_half,ecl_make_fixnum(1),ecl_make_fixnum(2),static,const); -ecl_def_ct_ratio(minus_half,ecl_make_fixnum(-1),ecl_make_fixnum(2),static,const); -ecl_def_ct_single_float(flt_one,1,static,const); -ecl_def_ct_single_float(flt_one_neg,-1,static,const); -ecl_def_ct_single_float(flt_two,2,static,const); -ecl_def_ct_complex(flt_imag_unit,&flt_zero_data,&flt_one_data,static,const); -ecl_def_ct_complex(flt_imag_unit_neg,&flt_zero_data,&flt_one_neg_data,static,const); -ecl_def_ct_complex(flt_imag_two,&flt_zero_data,&flt_two_data,static,const); struct cl_core_struct cl_core = { .packages = ECL_NIL, @@ -384,9 +106,6 @@ struct cl_core_struct cl_core = { .c_package = ECL_NIL, .ffi_package = ECL_NIL, - .pathname_translations = ECL_NIL, - .library_pathname = ECL_NIL, - .terminal_io = ECL_NIL, .null_stream = ECL_NIL, .standard_input = ECL_NIL, @@ -396,61 +115,13 @@ struct cl_core_struct cl_core = { .dispatch_reader = ECL_NIL, .char_names = ECL_NIL, - .null_string = (cl_object)&str_empty_data, - - .plus_half = (cl_object)&plus_half_data, - .minus_half = (cl_object)&minus_half_data, - .imag_unit = (cl_object)&flt_imag_unit_data, - .minus_imag_unit = (cl_object)&flt_imag_unit_neg_data, - .imag_two = (cl_object)&flt_imag_two_data, - .singlefloat_zero = (cl_object)&flt_zero_data, - .doublefloat_zero = (cl_object)&dbl_zero_data, - .singlefloat_minus_zero = (cl_object)&flt_zero_neg_data, - .doublefloat_minus_zero = (cl_object)&dbl_zero_neg_data, - .longfloat_zero = (cl_object)&ldbl_zero_data, - .longfloat_minus_zero = (cl_object)&ldbl_zero_neg_data, - - .gensym_prefix = (cl_object)&str_G_data, - .gentemp_prefix = (cl_object)&str_T_data, - .gentemp_counter = ecl_make_fixnum(0), - .Jan1st1970UT = ECL_NIL, + .gensym_prefix = ECL_NIL, + .gentemp_prefix = ECL_NIL, + .gentemp_counter = ecl_make_fixnum(0), .system_properties = ECL_NIL, - - .first_env = &first_env, -#ifdef ECL_THREADS - .processes = ECL_NIL, -#endif - /* LIBRARIES is an adjustable vector of objects. It behaves as - a vector of weak pointers thanks to the magic in - gbc.d/alloc_2.d */ - .libraries = ECL_NIL, - - .max_heap_size = 0, - .bytes_consed = ECL_NIL, - .gc_counter = ECL_NIL, - .gc_stats = 0, - .path_max = 0, -#ifdef GBC_BOEHM - .safety_region = NULL, -#endif - - .default_sigmask = NULL, - .default_sigmask_bytes = 0, - -#ifdef ECL_THREADS - .last_var_index = 0, - .reused_indices = ECL_NIL, -#endif - .slash = (cl_object)&str_slash_data, - .compiler_dispatch = ECL_NIL, - - .rehash_size = (cl_object)&default_rehash_size_data, - .rehash_threshold = (cl_object)&default_rehash_threshold_data, - - .known_signals = ECL_NIL }; #if !defined(ECL_MS_WINDOWS_HOST) @@ -475,6 +146,42 @@ maybe_fix_console_stream(cl_object stream) } #endif +static void +init_early_symbol(cl_object symbol, cl_object package) { + symbol->symbol.undef_entry = ecl_undefined_function_entry; + ECL_FMAKUNBOUND(symbol); + cl_import2(symbol, package); + cl_export2(symbol, package); +} + +static void +init_ecl_symbols() +{ + init_early_symbol(ECL_SIGNAL_HANDLERS, cl_core.system_package); + init_early_symbol(ECL_RESTART_CLUSTERS, cl_core.system_package); + init_early_symbol(ECL_INTERRUPTS_ENABLED, cl_core.system_package); + init_early_symbol(ECL_T, cl_core.lisp_package); + init_early_symbol(ECL_UNBOUND, cl_core.system_package); + + /* SYSTEM:UNBOUND has an associated function si_unbound that returns it. */ + ECL_SYM_FUN(ECL_UNBOUND) + = ecl_make_cfun((cl_objectfn_fixed)si_unbound, ECL_UNBOUND, NULL, 0); + + /* Initialize the :ALLOW-OTHER-KEYS symbol (it is not part of cl_symbols). */ + { + cl_object p = cl_core.keyword_package; + cl_object s = ECL_ALLOW_OTHER_KEYS; + cl_object n = s->symbol.name; + ECL_SET(s, OBJNULL); + ECL_FMAKUNBOUND(s); + s->symbol.hpack = p; + s->symbol.undef_entry = ecl_undefined_function_entry; + ecl_symbol_type_set(s, ecl_symbol_type(s) | ecl_stp_constant); + ECL_SET(s, s); + p->pack.external = _ecl_sethash(n, p->pack.external, s); + } +} + int cl_boot(int argc, char **argv) { @@ -483,40 +190,34 @@ cl_boot(int argc, char **argv) int i; cl_env_ptr env; - i = ecl_option_values[ECL_OPT_BOOTED]; - if (i) { - if (i < 0) { - /* We have called cl_shutdown and want to use ECL again. */ - ecl_set_option(ECL_OPT_BOOTED, 1); - } - return 1; - } - - /*ecl_set_option(ECL_OPT_SIGNAL_HANDLING_THREAD, 0);*/ - -#if !defined(GBC_BOEHM) - setbuf(stdin, stdin_buf); - setbuf(stdout, stdout_buf); -#endif - init_process(); + i = ecl_boot(); + if (i==1) return 1; ARGC = argc; ARGV = argv; ecl_self = argv[0]; - init_unixint(0); - init_alloc(0); - init_big(); + ecl_add_module(ecl_module_process); + ecl_add_module(ecl_module_stacks); + ecl_add_module(ecl_module_gc); + ecl_add_module(ecl_module_unixint); +#ifdef ECL_THREADS + ecl_add_module(ecl_module_thread); +#endif + ecl_add_module(ecl_module_bignum); + ecl_add_module(ecl_module_ffi); + ecl_add_module(ecl_module_aux); /* * Initialize the per-thread data. * This cannot come later, because we need to be able to bind - * ext::*interrupts-enabled* while creating packages. + * ECL_INTERRUPTS_ENABLED while creating packages. */ - env = cl_core.first_env; - ecl_init_first_env(env); - ecl_cs_set_org(env); + env = ecl_core.first_env; + + /* We need to enable GC because a lot of stuff is to be created */ + ecl_module_gc->module.enable(); /* * 1) Initialize symbols and packages @@ -538,27 +239,8 @@ cl_boot(int argc, char **argv) #endif cl_num_symbols_in_core=1; - ECL_T->symbol.t = (short)t_symbol; - ECL_T->symbol.value = ECL_T; - ECL_T->symbol.name = str_T; - ECL_T->symbol.cname = ECL_NIL; - ECL_FMAKUNBOUND(ECL_T); - ECL_T->symbol.sfdef = ECL_NIL; - ECL_T->symbol.macfun = ECL_NIL; - ECL_T->symbol.plist = ECL_NIL; - ECL_T->symbol.hpack = ECL_NIL; - ECL_T->symbol.stype = ecl_stp_constant; - ECL_T->symbol.undef_entry = ecl_undefined_function_entry; -#ifdef ECL_THREADS - ECL_T->symbol.binding = ECL_MISSING_SPECIAL_BINDING; -#endif - cl_num_symbols_in_core=2; - -#ifdef NO_PATH_MAX - cl_core.path_max = sysconf(_PC_PATH_MAX); -#else - cl_core.path_max = MAXPATHLEN; -#endif + cl_core.gensym_prefix = (cl_object)&str_G_data; + cl_core.gentemp_prefix = (cl_object)&str_T_data; cl_core.lisp_package = ecl_make_package(str_common_lisp, @@ -616,18 +298,16 @@ cl_boot(int argc, char **argv) cl_import2(ECL_NIL, cl_core.lisp_package); cl_export2(ECL_NIL, cl_core.lisp_package); - ECL_T->symbol.hpack = cl_core.lisp_package; - cl_import2(ECL_T, cl_core.lisp_package); - cl_export2(ECL_T, cl_core.lisp_package); - /* At exit, clean up */ atexit(cl_shutdown); - /* These must come _after_ the packages and NIL/T have been created */ + /* These must come _after_ the packages have been created */ + init_ecl_symbols(); init_all_symbols(); - /* We need to enable GC because a lot of stuff is to be created */ - init_alloc(1); + /* Set the default exception handler that coerces exceptions to conditions + that are understood by the condition system. */ + ECL_SET(ECL_SIGNAL_HANDLERS, ecl_list1(ECL_SYM_FUN(@'si::exception-handler'))); /* * Set *default-pathname-defaults* to a temporary fake value. We @@ -649,8 +329,8 @@ cl_boot(int argc, char **argv) */ cl_core.char_names = aux = cl__make_hash_table(@'equalp', ecl_make_fixnum(128), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); for (i = 0; char_names[i].elt.self; i++) { cl_object name = (cl_object)(char_names + i); cl_object code = ecl_make_fixnum(i); @@ -676,8 +356,8 @@ cl_boot(int argc, char **argv) */ cl_core.system_properties = cl__make_hash_table(@'equal', ecl_make_fixnum(1024), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); ECL_SET(@'*random-state*', ecl_make_random_state(ECL_T)); @@ -742,8 +422,8 @@ cl_boot(int argc, char **argv) */ ECL_SET(@'si::*class-name-hash-table*', cl__make_hash_table(@'eq', ecl_make_fixnum(1024), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold)); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold)); /* * Features. @@ -784,11 +464,56 @@ cl_boot(int argc, char **argv) /* Jump to top level */ ECL_SET(@'*package*', cl_core.user_package); - init_unixint(1); + ecl_module_unixint->module.enable(); return 1; } -/************************* ENVIRONMENT ROUTINES ***********************/ +/* -- Module definition (auxiliary structures) ---------------------- */ + +static cl_object +create_aux() +{ + cl_env_ptr the_env = ecl_core.first_env; + the_env->method_cache = NULL; + the_env->slot_cache = NULL; + return ECL_NIL; +} + +static cl_object +init_env_aux(cl_env_ptr the_env) +{ + /* Reader */ + the_env->string_pool = ECL_NIL; + the_env->packages_to_be_created = ECL_NIL; + the_env->packages_to_be_created_p = ECL_NIL; + /* Format (written in C) */ +#if !defined(ECL_CMU_FORMAT) + the_env->fmt_aux_stream = ecl_make_string_output_stream(64, 1); +#endif + /* Bytecodes compiler environment */ + the_env->c_env = NULL; + /* CLOS caches */ + the_env->method_cache = ecl_make_cache(64, 4096); + the_env->slot_cache = ecl_make_cache(3, 4096); + return ECL_NIL; +} + +ecl_def_ct_base_string(str_aux, "AUX", 3, static, const); + +static struct ecl_module module_aux = { + .name = str_aux, + .create = create_aux, + .enable = ecl_module_no_op, + .init_env = init_env_aux, + .init_cpu = ecl_module_no_op_env, + .free_cpu = ecl_module_no_op_cpu, + .free_env = ecl_module_no_op_env, + .disable = ecl_module_no_op, + .destroy = ecl_module_no_op +}; +cl_object ecl_module_aux = (cl_object)&module_aux; + +/* -- Operating system environment routines ------------------------- */ @(defun ext::quit (&optional (code ecl_make_fixnum(0)) (kill_all_threads ECL_T)) @ { @@ -814,8 +539,8 @@ cl_boot(int argc, char **argv) } #endif ECL_SET(@'ext::*program-exit-code*', code); - if (the_env->frs_org <= the_env->frs_top) - ecl_unwind(the_env, the_env->frs_org); + if (the_env->frs_stack.org <= the_env->frs_stack.top) + ecl_unwind(the_env, the_env->frs_stack.org); si_exit(1, code); } @) diff --git a/src/c/alloc_2.d b/src/c/mem_gc.d similarity index 85% rename from src/c/alloc_2.d rename to src/c/mem_gc.d index 6c55be548a45025945f063429bc909bb60c62fea..56f8afb50fad3159cc497ebf4f9395cd921e0412 100644 --- a/src/c/alloc_2.d +++ b/src/c/mem_gc.d @@ -1,17 +1,16 @@ /* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ /* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ -/* - * alloc_2.c - memory allocation based on the Boehm GC - * - * Copyright (c) 2001 Juan Jose Garcia Ripoll - * - * See file 'LICENSE' for the copyright details. - * - */ +/* mem_gc.d - automatic memory allocator and garbage collector based on bdwgc */ -#include +/* -- imports ---------------------------------------------------------------- */ #include +#include +#include +#include + +#include + #ifdef ECL_THREADS # ifdef ECL_WINDOWS_THREADS # include @@ -19,21 +18,24 @@ # include # endif #endif + #include #include #include + #ifdef ECL_WSOCK -#include +# include #endif #ifdef GBC_BOEHM -#include +# include +#endif static void (*GC_old_start_callback)(void) = NULL; static void gather_statistics(void); static void update_bytes_consed(void); static void ecl_mark_env(struct cl_env_struct *env); - + #ifdef GBC_BOEHM_PRECISE # if GBC_BOEHM # undef GBC_BOEHM_PRECISE @@ -45,22 +47,20 @@ static void **cl_object_free_list; # endif #endif -/********************************************************** - * OBJECT ALLOCATION * - **********************************************************/ +/* -- object allocation ------------------------------------------------------ */ void _ecl_set_max_heap_size(size_t new_size) { const cl_env_ptr the_env = ecl_process_env(); ecl_disable_interrupts_env(the_env); - GC_set_max_heap_size(cl_core.max_heap_size = new_size); + GC_set_max_heap_size(ecl_core.max_heap_size = new_size); if (new_size == 0) { cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; - cl_core.safety_region = ecl_alloc_atomic_unprotected(size); - } else if (cl_core.safety_region) { - GC_FREE(cl_core.safety_region); - cl_core.safety_region = 0; + ecl_core.safety_region = ecl_alloc_atomic_unprotected(size); + } else if (ecl_core.safety_region) { + GC_FREE(ecl_core.safety_region); + ecl_core.safety_region = 0; } ecl_enable_interrupts_env(the_env); } @@ -85,18 +85,18 @@ out_of_memory(size_t requested_bytes) int interrupts = the_env->disable_interrupts; int method = 0; void *output; - /* Disable interrupts only with the ext::*interrupts-enabled* - * mechanism to allow for writes in the thread local environment */ + /* Disable interrupts only with the ECL_INTERRUPTS_ENABLED mechanism to allow + * for writes in the thread local environment */ if (interrupts) ecl_enable_interrupts_env(the_env); - ecl_bds_bind(the_env, @'ext::*interrupts-enabled*', ECL_NIL); + ecl_bds_bind(the_env, ECL_INTERRUPTS_ENABLED, ECL_NIL); /* Free the input / output buffers */ the_env->string_pool = ECL_NIL; /* The out of memory condition may happen in more than one thread */ /* But then we have to ensure the error has not been solved */ #ifdef ECL_THREADS - ecl_mutex_lock(&cl_core.error_lock); + ecl_mutex_lock(&ecl_core.error_lock); ECL_UNWIND_PROTECT_BEGIN(the_env) #endif { @@ -111,23 +111,23 @@ out_of_memory(size_t requested_bytes) goto OUTPUT; } } - if (cl_core.max_heap_size == 0) { + if (ecl_core.max_heap_size == 0) { /* We did not set any limit in the amount of memory, * yet we failed, or we had some limits but we have * not reached them. */ - if (cl_core.safety_region) { + if (ecl_core.safety_region) { /* We can free some memory and try handling the error */ - GC_FREE(cl_core.safety_region); + GC_FREE(ecl_core.safety_region); the_env->string_pool = ECL_NIL; - cl_core.safety_region = 0; + ecl_core.safety_region = 0; method = 0; } else { /* No possibility of continuing */ method = 2; } } else { - cl_core.max_heap_size += ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; - GC_set_max_heap_size(cl_core.max_heap_size); + ecl_core.max_heap_size += ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; + GC_set_max_heap_size(ecl_core.max_heap_size); method = 1; } OUTPUT: @@ -135,7 +135,7 @@ out_of_memory(size_t requested_bytes) } #ifdef ECL_THREADS ECL_UNWIND_PROTECT_EXIT { - ecl_mutex_unlock(&cl_core.error_lock); + ecl_mutex_unlock(&ecl_core.error_lock); } ECL_UNWIND_PROTECT_END; #endif ecl_bds_unwind1(the_env); @@ -143,8 +143,7 @@ out_of_memory(size_t requested_bytes) switch (method) { case 0: cl_error(1, @'ext::storage-exhausted'); break; - case 1: cl_cerror(2, @"Extend heap size", - @'ext::storage-exhausted'); + case 1: cl_cerror(2, @"Extend heap size", @'ext::storage-exhausted'); break; case 2: return output; @@ -154,8 +153,8 @@ out_of_memory(size_t requested_bytes) } if (!interrupts) ecl_disable_interrupts_env(the_env); - GC_set_max_heap_size(cl_core.max_heap_size += - cl_core.max_heap_size / 2); + ecl_core.max_heap_size += (ecl_core.max_heap_size / 2); + GC_set_max_heap_size(ecl_core.max_heap_size); /* Default allocation. Note that we do not allocate atomic. */ return GC_MALLOC(requested_bytes); } @@ -470,6 +469,56 @@ ecl_dealloc(void *ptr) ecl_enable_interrupts_env(the_env); } +/* -- weak pointers ---------------------------------------------------------- */ + +cl_object +ecl_alloc_weak_pointer(cl_object o) +{ + const cl_env_ptr the_env = ecl_process_env(); + struct ecl_weak_pointer *obj; + ecl_disable_interrupts_env(the_env); + obj = GC_MALLOC_ATOMIC(sizeof(struct ecl_weak_pointer)); + ecl_enable_interrupts_env(the_env); + obj->t = t_weak_pointer; + obj->value = o; + if (!ECL_IMMEDIATE(o)) { + GC_GENERAL_REGISTER_DISAPPEARING_LINK((void**)&(obj->value), (void*)o); + si_set_finalizer((cl_object)obj, ECL_T); + } + return (cl_object)obj; +} + +static cl_object +ecl_weak_pointer_value(cl_object o) +{ + return ecl_weak_pointer(o); +} + +cl_object +si_make_weak_pointer(cl_object o) +{ + cl_object pointer = ecl_alloc_weak_pointer(o); + @(return pointer); +} + +cl_object +si_weak_pointer_value(cl_object o) +{ + const cl_env_ptr the_env = ecl_process_env(); + cl_object value; + if (ecl_unlikely(ecl_t_of(o) != t_weak_pointer)) + FEwrong_type_only_arg(@[ext::weak-pointer-value], o, + @[ext::weak-pointer]); + value = (cl_object)GC_call_with_alloc_lock((GC_fn_type)ecl_weak_pointer_value, o); + if (value) { + ecl_return2(the_env, value, ECL_T); + } else { + ecl_return2(the_env, ECL_NIL, ECL_NIL); + } +} + +/* -- graph traversal -------------------------------------------------------- */ + #ifdef GBC_BOEHM_PRECISE static cl_index to_bitmap(void *x, void *y) @@ -552,6 +601,8 @@ void init_type_info (void) init_tm(t_codeblock, "CODEBLOCK", sizeof(struct ecl_codeblock), -1); init_tm(t_foreign, "FOREIGN", sizeof(struct ecl_foreign), 2); init_tm(t_frame, "STACK-FRAME", sizeof(struct ecl_stack_frame), 0); + init_tm(t_exception, "EXCEPTION", sizeof(struct ecl_exception), 3); + init_tm(t_module, "MODULE", sizeof(struct ecl_module), 2); init_tm(t_weak_pointer, "WEAK-POINTER", sizeof(struct ecl_weak_pointer), 0); #ifdef ECL_SSE2 init_tm(t_sse_pack, "SSE-PACK", sizeof(struct ecl_sse_pack), 0); @@ -710,6 +761,11 @@ void init_type_info (void) to_bitmap(&o, &(o.foreign.tag)); type_info[t_frame].descriptor = to_bitmap(&o, &(o.frame.env)); + type_info[t_exception].descriptor = + to_bitmap(&o, &(o.exception.arg1)) | + to_bitmap(&o, &(o.exception.arg2)) | + to_bitmap(&o, &(o.exception.arg3)); + type_info[t_module].descriptor = 0; type_info[t_weak_pointer].descriptor = 0; #ifdef ECL_SSE2 type_info[t_sse_pack].descriptor = 0; @@ -744,78 +800,7 @@ extern void (*GC_push_other_roots)(); static void (*old_GC_push_other_roots)(); static void stacks_scanner(); -void -init_alloc(int pass) -{ - if (pass == 1) { - GC_enable(); - return; - } - /* - * Garbage collector restrictions: we set up the garbage collector - * library to work as follows - * - * 1) The garbage collector shall not scan shared libraries - * explicitely. - * 2) We only detect objects that are referenced by a pointer to - * the begining or to the first byte. - * 3) Out of the incremental garbage collector, we only use the - * generational component. - * 4) GC should handle fork() which is used to run subprocess on - * some platforms. - */ - GC_set_no_dls(1); - GC_set_all_interior_pointers(0); - GC_set_time_limit(GC_TIME_UNLIMITED); -#ifndef ECL_MS_WINDOWS_HOST - GC_set_handle_fork(1); -#endif - GC_init(); -#ifdef ECL_THREADS -# if GC_VERSION_MAJOR > 7 || GC_VERSION_MINOR > 1 - GC_allow_register_threads(); -# endif -#endif - if (ecl_option_values[ECL_OPT_INCREMENTAL_GC]) { - GC_enable_incremental(); - } - GC_register_displacement(1); - GC_clear_roots(); - GC_disable(); - -#ifdef GBC_BOEHM_PRECISE -# ifdef GBC_BOEHM_OWN_MARKER - cl_object_free_list = (void **)GC_new_free_list_inner(); - cl_object_mark_proc_index = GC_new_proc((GC_mark_proc)cl_object_mark_proc); - cl_object_kind = GC_new_kind_inner(cl_object_free_list, - GC_MAKE_PROC(cl_object_mark_proc_index, 0), - FALSE, TRUE); -# endif -#endif /* !GBC_BOEHM_PRECISE */ - - GC_set_max_heap_size(cl_core.max_heap_size = ecl_option_values[ECL_OPT_HEAP_SIZE]); - /* Save some memory for the case we get tight. */ - if (cl_core.max_heap_size == 0) { - cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; - cl_core.safety_region = ecl_alloc_atomic_unprotected(size); - } else if (cl_core.safety_region) { - cl_core.safety_region = 0; - } - - init_type_info(); - - old_GC_push_other_roots = GC_push_other_roots; - GC_push_other_roots = stacks_scanner; - GC_old_start_callback = GC_get_start_callback(); - GC_set_start_callback(gather_statistics); - GC_set_java_finalization(1); - GC_set_oom_fn(out_of_memory); - GC_set_warn_proc(no_warnings); -} - -/********************************************************** - * FINALIZATION * - **********************************************************/ +/* -- finalization ----------------------------------------------------------- */ static void standard_finalizer(cl_object o) @@ -889,7 +874,7 @@ standard_finalizer(cl_object o) } case t_symbol: { if (o->symbol.binding != ECL_MISSING_SPECIAL_BINDING) { - ecl_atomic_push(&cl_core.reused_indices, ecl_make_fixnum(o->symbol.binding)); + ecl_atomic_push(&ecl_core.reused_indices, ecl_make_fixnum(o->symbol.binding)); o->symbol.binding = ECL_MISSING_SPECIAL_BINDING; } } @@ -1052,6 +1037,8 @@ si_set_finalizer(cl_object o, cl_object finalizer) @(return); } +/* -- GC stats --------------------------------------------------------------- */ + /* If we do not build our own version of the library, we do not have * control over the existence of this variable. */ #if GBC_BOEHM == 0 @@ -1066,33 +1053,33 @@ si_gc_stats(cl_object enable) cl_object old_status; cl_object size1; cl_object size2; - if (cl_core.gc_stats == 0) { + if (ecl_core.gc_stats == 0) { old_status = ECL_NIL; } else if (GC_print_stats) { old_status = @':full'; } else { old_status = ECL_T; } - if (cl_core.bytes_consed == ECL_NIL) { - cl_core.bytes_consed = ecl_alloc_object(t_bignum); - mpz_init2(ecl_bignum(cl_core.bytes_consed), 128); - cl_core.gc_counter = ecl_alloc_object(t_bignum); - mpz_init2(ecl_bignum(cl_core.gc_counter), 128); + if (ecl_core.bytes_consed == ECL_NIL) { + ecl_core.bytes_consed = ecl_alloc_object(t_bignum); + mpz_init2(ecl_bignum(ecl_core.bytes_consed), 128); + ecl_core.gc_counter = ecl_alloc_object(t_bignum); + mpz_init2(ecl_bignum(ecl_core.gc_counter), 128); } update_bytes_consed(); /* We need fresh copies of the bignums */ - size1 = _ecl_big_register_copy(cl_core.bytes_consed); - size2 = _ecl_big_register_copy(cl_core.gc_counter); + size1 = _ecl_big_register_copy(ecl_core.bytes_consed); + size2 = _ecl_big_register_copy(ecl_core.gc_counter); if (enable == ECL_NIL) { GC_print_stats = 0; - cl_core.gc_stats = 0; + ecl_core.gc_stats = 0; } else if (enable == ecl_make_fixnum(0)) { - mpz_set_ui(ecl_bignum(cl_core.bytes_consed), 0); - mpz_set_ui(ecl_bignum(cl_core.gc_counter), 0); + mpz_set_ui(ecl_bignum(ecl_core.bytes_consed), 0); + mpz_set_ui(ecl_bignum(ecl_core.gc_counter), 0); } else { - cl_core.gc_stats = 1; + ecl_core.gc_stats = 1; GC_print_stats = (enable == @':full'); } @(return size1 size2 old_status); @@ -1105,10 +1092,10 @@ static void gather_statistics() { /* GC stats rely on bignums */ - if (cl_core.gc_stats) { + if (ecl_core.gc_stats) { update_bytes_consed(); - mpz_add_ui(ecl_bignum(cl_core.gc_counter), - ecl_bignum(cl_core.gc_counter), + mpz_add_ui(ecl_bignum(ecl_core.gc_counter), + ecl_bignum(ecl_core.gc_counter), 1); } if (GC_old_start_callback) @@ -1118,8 +1105,8 @@ gather_statistics() static void update_bytes_consed () { #if GBC_BOEHM == 0 - mpz_add_ui(ecl_bignum(cl_core.bytes_consed), - ecl_bignum(cl_core.bytes_consed), + mpz_add_ui(ecl_bignum(ecl_core.bytes_consed), + ecl_bignum(ecl_core.bytes_consed), GC_get_bytes_since_gc()); #else /* This is not accurate and may wrap around. We try to detect this @@ -1130,48 +1117,46 @@ update_bytes_consed () { if (bytes > new_bytes) { cl_index wrapped; wrapped = ~((cl_index)0) - bytes; - mpz_add_ui(ecl_bignum(cl_core.bytes_consed), - ecl_bignum(cl_core.bytes_consed), + mpz_add_ui(ecl_bignum(ecl_core.bytes_consed), + ecl_bignum(ecl_core.bytes_consed), wrapped); - mpz_add_ui(ecl_bignum(cl_core.bytes_consed), - ecl_bignum(cl_core.bytes_consed), + mpz_add_ui(ecl_bignum(ecl_core.bytes_consed), + ecl_bignum(ecl_core.bytes_consed), new_bytes); } else { - mpz_add_ui(ecl_bignum(cl_core.bytes_consed), - ecl_bignum(cl_core.bytes_consed), + mpz_add_ui(ecl_bignum(ecl_core.bytes_consed), + ecl_bignum(ecl_core.bytes_consed), new_bytes - bytes); } bytes = new_bytes; #endif } -/********************************************************** - * GARBAGE COLLECTOR * - **********************************************************/ +/* -- garbage collection ----------------------------------------------------- */ static void ecl_mark_env(struct cl_env_struct *env) { - if (env->stack) { - GC_push_conditional((void *)env->stack, (void *)env->stack_top, 1); - GC_set_mark_bit((void *)env->stack); - } - if (env->frs_top) { - GC_push_conditional((void *)env->frs_org, (void *)(env->frs_top+1), 1); - GC_set_mark_bit((void *)env->frs_org); - } - if (env->bds_top) { - GC_push_conditional((void *)env->bds_org, (void *)(env->bds_top+1), 1); - GC_set_mark_bit((void *)env->bds_org); - } - /* When not using threads, "env" is mmaped or statically allocated. */ + /* Environments and stacks are allocated without GC */ + if (env->run_stack.org) + GC_push_all((void *)env->run_stack.org, (void *)env->run_stack.top); + if (env->frs_stack.org) + GC_push_all((void *)env->frs_stack.org, (void *)(env->frs_stack.top+1)); + if (env->bds_stack.org) + GC_push_all((void *)env->bds_stack.org, (void *)(env->bds_stack.top+1)); +#ifdef ECL_THREADS + if (env->bds_stack.tl_bindings) + GC_push_all((void *)env->bds_stack.tl_bindings, + (void *)(env->bds_stack.tl_bindings + + env->bds_stack.tl_bindings_size)); +#endif GC_push_all((void *)env, (void *)(env + 1)); } static void stacks_scanner() { - cl_object l = cl_core.libraries; + cl_object l = ecl_core.libraries; loop_for_on_unsafe(l) { cl_object dll = ECL_CONS_CAR(l); if (dll->cblock.locked) { @@ -1179,30 +1164,25 @@ stacks_scanner() GC_set_mark_bit((void *)dll); } } end_loop_for_on_unsafe(l); + /* ECL runtime */ + GC_push_all((void *)(&ecl_core), (void *)(&ecl_core + 1)); + GC_push_all((void *)(ECL_SIGNAL_HANDLERS), + (void *)(ECL_SIGNAL_HANDLERS + 1)); + /* Common Lisp */ GC_push_all((void *)(&cl_core), (void *)(&cl_core + 1)); GC_push_all((void *)cl_symbols, (void *)(cl_symbols + cl_num_symbols_in_core)); - ecl_mark_env(cl_core.first_env); + ecl_mark_env(ecl_core.first_env); #ifdef ECL_THREADS - l = cl_core.processes; - if (l != OBJNULL) { - cl_index i, size; - for (i = 0, size = l->vector.dim; i < size; i++) { - cl_object process = l->vector.self.t[i]; - if (!Null(process)) { - cl_env_ptr env = process->process.env; - if (env && (env != cl_core.first_env)) ecl_mark_env(env); - } - } - } + loop_across_stack_fifo(_env, ecl_core.threads) { + cl_env_ptr env = ecl_cast_ptr(cl_env_ptr, _env); + if(env != ecl_core.first_env) + ecl_mark_env(env); + } end_loop_across_stack(); #endif if (old_GC_push_other_roots) (*old_GC_push_other_roots)(); } -/********************************************************** - * GARBAGE COLLECTION * - **********************************************************/ - void ecl_register_root(cl_object *p) { @@ -1232,54 +1212,130 @@ si_gc_dump() @(return); } -/********************************************************************** - * WEAK POINTERS - */ +/* -- module definition ------------------------------------------------------ */ -cl_object -ecl_alloc_weak_pointer(cl_object o) +static cl_object +create_gc() { - const cl_env_ptr the_env = ecl_process_env(); - struct ecl_weak_pointer *obj; - ecl_disable_interrupts_env(the_env); - obj = GC_MALLOC_ATOMIC(sizeof(struct ecl_weak_pointer)); - ecl_enable_interrupts_env(the_env); - obj->t = t_weak_pointer; - obj->value = o; - if (!ECL_IMMEDIATE(o)) { - GC_GENERAL_REGISTER_DISAPPEARING_LINK((void**)&(obj->value), (void*)o); - si_set_finalizer((cl_object)obj, ECL_T); + /* + * Garbage collector restrictions: we set up the garbage collector + * library to work as follows + * + * 1) The garbage collector shall not scan shared libraries + * explicitely. + * 2) We only detect objects that are referenced by a pointer to + * the begining or to the first byte. + * 3) Out of the incremental garbage collector, we only use the + * generational component. + * 4) GC should handle fork() which is used to run subprocess on + * some platforms. + */ + GC_set_no_dls(1); + GC_set_all_interior_pointers(0); + GC_set_time_limit(GC_TIME_UNLIMITED); +#ifndef ECL_MS_WINDOWS_HOST + GC_set_handle_fork(1); +#endif + GC_init(); +#ifdef ECL_THREADS +# if GC_VERSION_MAJOR > 7 || GC_VERSION_MINOR > 1 + GC_allow_register_threads(); +# endif +#endif + if (ecl_option_values[ECL_OPT_INCREMENTAL_GC]) { + GC_enable_incremental(); } - return (cl_object)obj; + GC_register_displacement(1); + GC_clear_roots(); + GC_disable(); + +#ifdef GBC_BOEHM_PRECISE +# ifdef GBC_BOEHM_OWN_MARKER + cl_object_free_list = (void **)GC_new_free_list_inner(); + cl_object_mark_proc_index = GC_new_proc((GC_mark_proc)cl_object_mark_proc); + cl_object_kind = GC_new_kind_inner(cl_object_free_list, + GC_MAKE_PROC(cl_object_mark_proc_index, 0), + FALSE, TRUE); +# endif +#endif /* !GBC_BOEHM_PRECISE */ + ecl_core.max_heap_size = ecl_option_values[ECL_OPT_HEAP_SIZE]; + GC_set_max_heap_size(ecl_core.max_heap_size); + /* Save some memory for the case we get tight. */ + if (ecl_core.max_heap_size == 0) { + cl_index size = ecl_option_values[ECL_OPT_HEAP_SAFETY_AREA]; + ecl_core.safety_region = ecl_alloc_atomic_unprotected(size); + } else if (ecl_core.safety_region) { + ecl_core.safety_region = 0; + } + + init_type_info(); + + old_GC_push_other_roots = GC_push_other_roots; + GC_push_other_roots = stacks_scanner; + GC_old_start_callback = GC_get_start_callback(); + GC_set_start_callback(gather_statistics); + GC_set_java_finalization(1); + GC_set_oom_fn(out_of_memory); + GC_set_warn_proc(no_warnings); + + return ECL_NIL; } static cl_object -ecl_weak_pointer_value(cl_object o) +enable_gc () { - return ecl_weak_pointer(o); + GC_enable(); + return ECL_NIL; } -cl_object -si_make_weak_pointer(cl_object o) +static cl_object +disable_gc () { - cl_object pointer = ecl_alloc_weak_pointer(o); - @(return pointer); + GC_disable(); + return ECL_NIL; } -cl_object -si_weak_pointer_value(cl_object o) +static cl_object +init_cpu(cl_env_ptr the_env) { - const cl_env_ptr the_env = ecl_process_env(); - cl_object value; - if (ecl_unlikely(ecl_t_of(o) != t_weak_pointer)) - FEwrong_type_only_arg(@[ext::weak-pointer-value], o, - @[ext::weak-pointer]); - value = (cl_object)GC_call_with_alloc_lock((GC_fn_type)ecl_weak_pointer_value, o); - if (value) { - ecl_return2(the_env, value, ECL_T); - } else { - ecl_return2(the_env, ECL_NIL, ECL_NIL); +#ifdef GBC_BOEHM + struct GC_stack_base stack; + GC_get_stack_base(&stack); + the_env->c_stack.org = (char*)stack.mem_base; +# ifdef ECL_THREADS + if (GC_thread_is_registered() == 0) { + GC_register_my_thread(&stack); + } +# endif +#endif + return ECL_NIL; +} + +static cl_object +free_cpu() +{ +#ifdef GBC_BOEHM +# ifdef ECL_THREADS + if (GC_thread_is_registered() == 1) { + GC_unregister_my_thread(); } +# endif +#endif + return ECL_NIL; } -#endif /* GBC_BOEHM */ +ecl_def_ct_base_string(str_gc, "GC", 2, static, const); + +static struct ecl_module module_gc = { + .name = str_gc, + .create = create_gc, + .enable = enable_gc, + .init_env = ecl_module_no_op_env, + .init_cpu = init_cpu, + .free_cpu = free_cpu, + .free_env = ecl_module_no_op_env, + .disable = disable_gc, + .destroy = ecl_module_no_op +}; + +cl_object ecl_module_gc = (cl_object)&module_gc; diff --git a/src/c/module.d b/src/c/module.d new file mode 100644 index 0000000000000000000000000000000000000000..dd745640cfd21462e3c8a8175d81f4b71e48d866 --- /dev/null +++ b/src/c/module.d @@ -0,0 +1,178 @@ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ + +/* module.c - managing runtime modules */ + +/* -- imports ---------------------------------------------------------------- */ +#include +#include +#include +#include + +/* -- test module ------------------------------------------------------------ */ + +static cl_object create() { + printf("DUMMY: Creating the module!\n"); + return ECL_NIL; +} + +static cl_object enable() { + printf("DUMMY: Enabling the module!\n"); + return ECL_NIL; +} + +static cl_object init_env(cl_env_ptr the_env) { +#ifdef ECL_THREADS + ecl_thread_t thread_id = the_env->thread; + printf("DUMMY: init_env [cpu %p env %p]\n", &thread_id, the_env); +#else + printf("DUMMY: init_env [env %p]\n", the_env); +#endif + return ECL_NIL; +} + +static cl_object init_cpu(cl_env_ptr the_env) { +#ifdef ECL_THREADS + ecl_thread_t thread_id = the_env->thread; + printf("DUMMY: init_cpu [cpu %p env %p]\n", &thread_id, the_env); +#else + printf("DUMMY: init_cpu [env %p]\n", the_env); +#endif + return ECL_NIL; +} + +static cl_object free_cpu(cl_env_ptr the_env) { +#ifdef ECL_THREADS + ecl_thread_t thread_id = the_env->thread; + printf("DUMMY: free_cpu [cpu %p env %p]\n", &thread_id, the_env); +#else + printf("DUMMY: free_cpu [env %p]\n", the_env); +#endif + return ECL_NIL; +} + +static cl_object free_env(cl_env_ptr the_env) { +#ifdef ECL_THREADS + ecl_thread_t thread_id = the_env->thread; + printf("DUMMY: free_env [cpu %p env %p]\n", &thread_id, the_env); +#else + printf("DUMMY: free_env [env %p]\n", the_env); +#endif + return ECL_NIL; +} + +static cl_object disable() { + printf("DUMMY: Disabling the module!\n"); + return ECL_NIL; +} + +static cl_object destroy() { + printf("DUMMY: Destroying the module!\n"); + return ECL_NIL; +} + +ecl_def_ct_base_string(str_dummy, "DUMMY", 5, static, const); + +static struct ecl_module module_dummy = { + .name = str_dummy, + .create = create, + .enable = enable, + .init_env = init_env, + .init_cpu = init_cpu, + .free_cpu = free_cpu, + .free_env = free_env, + .disable = disable, + .destroy = destroy +}; + +cl_object ecl_module_dummy = (cl_object)&module_dummy; + +/* -- implementation --------------------------------------------------------- */ + +cl_object +ecl_module_no_op() +{ + return ECL_NIL; +} + +cl_object +ecl_module_no_op_env(cl_env_ptr the_env) +{ + return ECL_NIL; +} + +cl_object +ecl_module_no_op_cpu(cl_env_ptr the_env) +{ + return ECL_NIL; +} + +cl_object +ecl_add_module(cl_object self) +{ + self->module.create(); + self->module.init_cpu(ecl_core.first_env); + self->module.init_env(ecl_core.first_env); + ecl_stack_push(ecl_core.modules, self); + return ECL_NIL; +} + +cl_object +ecl_del_module(cl_object self) +{ + ecl_stack_del(ecl_core.modules, self); + self->module.disable(); + self->module.free_env(ecl_core.first_env); + self->module.free_cpu(ecl_core.first_env); + self->module.destroy(); + return ECL_NIL; +} + +cl_object +ecl_modules_init_env(cl_env_ptr the_env) { + loop_across_stack_fifo(var, ecl_core.modules) { + /* printf("> init_env: %s\n", (var->module.name)->base_string.self); */ + var->module.init_env(the_env); + /* printf("< init_env: %s\n", (var->module.name)->base_string.self); */ + } end_loop_across_stack(); + return ECL_NIL; +} + +cl_object +ecl_modules_init_cpu(cl_env_ptr the_env) { + loop_across_stack_fifo(var, ecl_core.modules) { + /* printf("> init_cpu: %s\n", (var->module.name)->base_string.self); */ + var->module.init_cpu(the_env); + /* printf("< init_cpu: %s\n", (var->module.name)->base_string.self); */ + } end_loop_across_stack(); + return ECL_NIL; +} + +cl_object +ecl_modules_free_cpu(cl_env_ptr the_env) { + loop_across_stack_filo(var, ecl_core.modules) { + /* printf("> free_cpu: %s\n", (var->module.name)->base_string.self); */ + var->module.free_cpu(the_env); + /* printf("< free_cpu: %s\n", (var->module.name)->base_string.self); */ + } end_loop_across_stack(); + return ECL_NIL; +} + +cl_object +ecl_modules_free_env(cl_env_ptr the_env) { + loop_across_stack_filo(var, ecl_core.modules) { + /* printf("> free_env: %s\n", (var->module.name)->base_string.self); */ + var->module.free_env(the_env); + /* printf("< free_env: %s\n", (var->module.name)->base_string.self); */ + } end_loop_across_stack(); + return ECL_NIL; +} + +/* INV all modules must be loaded before we make new threads. */ +/* FIXME enforce this invariant. */ +void +init_modules() +{ + cl_object self = ecl_make_stack(16); + ecl_core.modules = self; +} diff --git a/src/c/num_co.d b/src/c/num_co.d index 1a88fc970984becaae4ac780c8662b388b8b99c3..d347b3552f15da449f77d3b7bb7666709bb553a8 100644 --- a/src/c/num_co.d +++ b/src/c/num_co.d @@ -431,21 +431,21 @@ cl_imagpart(cl_object x) break; case t_singlefloat: if (signbit(ecl_single_float(x))) - x = cl_core.singlefloat_minus_zero; + x = ecl_ct_singlefloat_minus_zero; else - x = cl_core.singlefloat_zero; + x = ecl_ct_singlefloat_zero; break; case t_doublefloat: if (signbit(ecl_double_float(x))) - x = cl_core.doublefloat_minus_zero; + x = ecl_ct_doublefloat_minus_zero; else - x = cl_core.doublefloat_zero; + x = ecl_ct_doublefloat_zero; break; case t_longfloat: if (signbit(ecl_long_float(x))) - x = cl_core.longfloat_minus_zero; + x = ecl_ct_longfloat_minus_zero; else - x = cl_core.longfloat_zero; + x = ecl_ct_longfloat_zero; break; case t_complex: x = x->gencomplex.imag; diff --git a/src/c/number.d b/src/c/number.d index ad281010743ef5ce6563ba2573b114fc47a5775b..8de5d5d9d4e43d08435bd8ed142738a923814273 100644 --- a/src/c/number.d +++ b/src/c/number.d @@ -501,9 +501,9 @@ ecl_make_single_float(float f) if (f == (float)0.0) { #if defined(ECL_SIGNED_ZERO) if (signbit(f)) - return cl_core.singlefloat_minus_zero; + return ecl_ct_singlefloat_minus_zero; #endif - return cl_core.singlefloat_zero; + return ecl_ct_singlefloat_zero; } x = ecl_alloc_object(t_singlefloat); ecl_single_float(x) = f; @@ -519,9 +519,9 @@ ecl_make_double_float(double f) if (f == (double)0.0) { #if defined(ECL_SIGNED_ZERO) if (signbit(f)) - return cl_core.doublefloat_minus_zero; + return ecl_ct_doublefloat_minus_zero; #endif - return cl_core.doublefloat_zero; + return ecl_ct_doublefloat_zero; } x = ecl_alloc_object(t_doublefloat); ecl_double_float(x) = f; @@ -537,9 +537,9 @@ ecl_make_long_float(long double f) if (f == (long double)0.0) { #if defined(ECL_SIGNED_ZERO) if (signbit(f)) - return cl_core.longfloat_minus_zero; + return ecl_ct_longfloat_minus_zero; #endif - return cl_core.longfloat_zero; + return ecl_ct_longfloat_zero; } x = ecl_alloc_object(t_longfloat); x->longfloat.value = f; diff --git a/src/c/numbers/atan.d b/src/c/numbers/atan.d index e63bc8a5ef6e01e7c3afff3d9a1e7701fff38f40..af55f7c9c39e1025afc31594df2522fe97f04a6c 100644 --- a/src/c/numbers/atan.d +++ b/src/c/numbers/atan.d @@ -15,11 +15,19 @@ #define ECL_INCLUDE_MATH_H #include +#include #include #include #pragma STDC FENV_ACCESS ON +ecl_def_ct_single_float(ecl_ct_flt_zero,0,static,const); +ecl_def_ct_single_float(ecl_ct_flt_one,1,static,const); +ecl_def_ct_single_float(ecl_ct_flt_one_neg,-1,static,const); + +ecl_def_ct_complex(ecl_ct_imag_unit,ecl_ct_flt_zero,ecl_ct_flt_one,static,const); +ecl_def_ct_complex(ecl_ct_minus_imag_unit,ecl_ct_flt_zero,ecl_ct_flt_one_neg,static,const); + cl_object ecl_atan2(cl_object y, cl_object x) { @@ -53,20 +61,20 @@ ecl_atan1(cl_object y) { if (ECL_COMPLEXP(y)) { #if 0 /* ANSI states it should be this first part */ - cl_object z = ecl_times(cl_core.imag_unit, y); + cl_object z = ecl_times(ecl_ct_imag_unit, y); z = ecl_plus(ecl_log1(ecl_one_plus(z)), ecl_log1(ecl_minus(ecl_make_fixnum(1), z))); z = ecl_divide(z, ecl_times(ecl_make_fixnum(2), - cl_core.imag_unit)); + ecl_ct_imag_unit)); #else - cl_object z1, z = ecl_times(cl_core.imag_unit, y); + cl_object z1, z = ecl_times(ecl_ct_imag_unit, y); z = ecl_one_plus(z); z1 = ecl_times(y, y); z1 = ecl_one_plus(z1); z1 = ecl_sqrt(z1); z = ecl_divide(z, z1); z = ecl_log1(z); - z = ecl_times(cl_core.minus_imag_unit, z); + z = ecl_times(ecl_ct_minus_imag_unit, z); #endif /* ANSI */ return z; } else { diff --git a/src/c/numbers/round.d b/src/c/numbers/round.d index b1b97060f150c06650d7fc65d55591177e3d9cbe..4d5ffaa39d5706884fc6a026e69d8e242eb60f91 100644 --- a/src/c/numbers/round.d +++ b/src/c/numbers/round.d @@ -87,12 +87,12 @@ ecl_round2_integer(const cl_env_ptr the_env, cl_object x, cl_object y, cl_object cl_object q1 = ecl_integer_divide(q->ratio.num, q->ratio.den); cl_object r = ecl_minus(q, q1); if (ecl_minusp(r)) { - int c = ecl_number_compare(cl_core.minus_half, r); + int c = ecl_number_compare(ecl_ct_minus_half, r); if (c > 0 || (c == 0 && ecl_oddp(q1))) { q1 = ecl_one_minus(q1); } } else { - int c = ecl_number_compare(r, cl_core.plus_half); + int c = ecl_number_compare(r, ecl_ct_plus_half); if (c > 0 || (c == 0 && ecl_oddp(q1))) { q1 = ecl_one_plus(q1); } diff --git a/src/c/numbers/sqrt.d b/src/c/numbers/sqrt.d index a8af7cae352c6b7af8b38bfedf0917dedea4a0d1..a35ac725c2263011d30817c892ce108bd9c90cef 100644 --- a/src/c/numbers/sqrt.d +++ b/src/c/numbers/sqrt.d @@ -76,7 +76,7 @@ ecl_sqrt_long_float(cl_object x) static cl_object ecl_sqrt_complex(cl_object x) { - return ecl_expt(x, cl_core.plus_half); + return ecl_expt(x, ecl_ct_plus_half); } #ifdef ECL_COMPLEX_FLOAT diff --git a/src/c/package.d b/src/c/package.d index e6d6e32389b7c2eb87f6c683dbc4147947fe4a22..2fc45f63ec273e575baf4b65908b289d3b5067f3 100644 --- a/src/c/package.d +++ b/src/c/package.d @@ -23,8 +23,8 @@ * NOTE 1: we only need to use the package locks when reading/writing the hash * tables, or changing the fields of a package. We do not need the locks to * read lists from the packages (i.e. list of shadowing symbols, used - * packages, etc), or from the global environment (cl_core.packages_list) if - * we do not destructively modify them (For instance, use ecl_remove_eq + * packages, etc), or from the global environment (cl_core.packages_list) + * if we do not destructively modify them (For instance, use ecl_remove_eq * instead of ecl_delete_eq). */ /* @@ -114,8 +114,8 @@ make_package_hashtable() { return cl__make_hash_table(@'package', /* package hash table */ ecl_make_fixnum(128), /* initial size */ - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); } static cl_object @@ -270,7 +270,7 @@ ecl_make_package(cl_object name, cl_object nicknames, nicknamed->pack.nicknamedby = CONS(x, nicknamed->pack.nicknamedby); } end_loop_for_in; /* Finally, add it to the list of packages */ - cl_core.packages = CONS(x, cl_core.packages); + cl_core.packages = ecl_cons(x, cl_core.packages); OUTPUT: (void)0; } ECL_WITH_GLOBAL_ENV_WRLOCK_END; diff --git a/src/c/pathname.d b/src/c/pathname.d index 32ebb52065ab26b86d8d4af1c95b2ed0e205c919..b470d0222a49db686175d354cfa8c59fc621613c 100644 --- a/src/c/pathname.d +++ b/src/c/pathname.d @@ -461,7 +461,7 @@ parse_word(cl_object s, delim_fn delim, int flags, cl_index start, case 0: if (flags & WORD_EMPTY_IS_NIL) return ECL_NIL; - return cl_core.null_string; + return ecl_ct_null_string; case 1: if (ecl_char(s,j) == '*') return @':wild'; @@ -505,7 +505,7 @@ parse_directories(cl_object s, int flags, cl_index start, cl_index end, cl_object part = parse_word(s, delim, flags, j, end, &i); if (part == @':error' || part == ECL_NIL) break; - if (part == cl_core.null_string) { /* "/", ";" */ + if (part == ecl_ct_null_string) { /* "/", ";" */ if (j != start) { if (flags & WORD_LOGICAL) return @':error'; @@ -525,7 +525,7 @@ ecl_logical_hostname_p(cl_object host) { if (!ecl_stringp(host)) return FALSE; - return !Null(ecl_assqlp(host, cl_core.pathname_translations)); + return !Null(ecl_assqlp(host, ecl_core.pathname_translations)); } /* @@ -562,7 +562,7 @@ ecl_parse_namestring(cl_object s, cl_index start, cl_index end, cl_index *ep, bool logical; if (start == end) { - host = device = path = name = type = aux = version = @'nil'; + host = device = path = name = type = aux = version = ECL_NIL; logical = 0; *ep = end; goto make_it; @@ -900,8 +900,8 @@ si_coerce_to_filename(cl_object pathname_orig) pathname_orig->pathname.type, pathname_orig->pathname.version); } - if (cl_core.path_max != -1 && - ecl_length(namestring) >= cl_core.path_max - 16) + if (ecl_core.path_max != -1 && + ecl_length(namestring) >= ecl_core.path_max - 16) FEerror("Too long filename: ~S.", 1, namestring); return namestring; } @@ -1318,7 +1318,7 @@ cl_host_namestring(cl_object pname) pname = cl_pathname(pname); pname = pname->pathname.host; if (Null(pname) || pname == @':wild') - pname = cl_core.null_string; + pname = ecl_ct_null_string; @(return pname); } @@ -1542,7 +1542,7 @@ coerce_to_from_pathname(cl_object x, cl_object host) FEerror("Wrong host syntax ~S", 1, host); } /* Find its translation list */ - pair = ecl_assqlp(host, cl_core.pathname_translations); + pair = ecl_assqlp(host, ecl_core.pathname_translations); if (set == OBJNULL) { @(return ((pair == ECL_NIL)? ECL_NIL : CADR(pair))); } @@ -1552,7 +1552,7 @@ coerce_to_from_pathname(cl_object x, cl_object host) } if (pair == ECL_NIL) { pair = CONS(host, CONS(ECL_NIL, ECL_NIL)); - cl_core.pathname_translations = CONS(pair, cl_core.pathname_translations); + ecl_core.pathname_translations = CONS(pair, ecl_core.pathname_translations); } for (l = set, set = ECL_NIL; !ecl_endp(l); l = CDR(l)) { cl_object item = CAR(l); diff --git a/src/c/printer/write_object.d b/src/c/printer/write_object.d index 1a8a0d61478eeb4a3546deab63e3b991411f2d5c..e75a3814da4cbd001b4a8b94ad319054f4e81ade 100644 --- a/src/c/printer/write_object.d +++ b/src/c/printer/write_object.d @@ -96,8 +96,8 @@ si_write_object_with_circle(cl_object x, cl_object stream, cl_object print_funct cl_object hash = cl__make_hash_table(@'eq', ecl_make_fixnum(1024), - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); ecl_bds_bind(env, @'si::*circle-counter*', ECL_T); ecl_bds_bind(env, @'si::*circle-stack*', hash); si_write_object_with_circle(x, cl_core.null_stream, print_function); diff --git a/src/c/printer/write_ugly.d b/src/c/printer/write_ugly.d index d99672ee154c0394088cd8e61dc80bfac8781d60..fcdb42bb0fa5d291960975810469ee7840fb0893 100644 --- a/src/c/printer/write_ugly.d +++ b/src/c/printer/write_ugly.d @@ -370,6 +370,18 @@ write_frame(cl_object x, cl_object stream) _ecl_write_unreadable(x, "frame", ecl_make_fixnum(x->frame.size), stream); } +static void +write_exception(cl_object x, cl_object stream) +{ + _ecl_write_unreadable(x, "exception", ECL_NIL, stream); +} + +static void +write_module(cl_object x, cl_object stream) +{ + _ecl_write_unreadable(x, "module", x->module.name, stream); +} + static void write_weak_pointer(cl_object x, cl_object stream) { @@ -480,6 +492,8 @@ static printer dispatch[FREE+1] = { write_codeblock, /* t_codeblock */ write_foreign, /* t_foreign */ write_frame, /* t_frame */ + write_exception, /* t_exception */ + write_module, /* t_module */ write_weak_pointer, /* t_weak_pointer */ #ifdef ECL_SSE2 _ecl_write_sse, /* t_sse_pack */ diff --git a/src/c/process.d b/src/c/process.d index 9f9fffda456c59e8519a9f30073bbae27bc557f7..4c55221459a88bedb6d1efe6aedd921801ddd666 100644 --- a/src/c/process.d +++ b/src/c/process.d @@ -36,11 +36,25 @@ #ifdef ECL_THREADS # ifdef ECL_WINDOWS_THREADS +# define ecl_process_eq(t1, t2) (GetThreadId(t1) == GetThreadId(t2)) +# define ecl_set_process_self(var) \ + { \ + HANDLE aux = GetCurrentThread(); \ + DuplicateHandle(GetCurrentProcess(), \ + aux, \ + GetCurrentProcess(), \ + &var, \ + 0, \ + FALSE, \ + DUPLICATE_SAME_ACCESS); \ + } # define ecl_process_key_t DWORD # define ecl_process_key_create(key) key = TlsAlloc() # define ecl_process_get_tls(key) TlsGetValue(key) # define ecl_process_set_tls(key,val) (TlsSetValue(key,val)!=0) # else +# define ecl_process_eq(t1, t2) (t1 == t2) +# define ecl_set_process_self(var) (var = pthread_self()) # define ecl_process_key_t static pthread_key_t # define ecl_process_key_create(key) pthread_key_create(&key, NULL) # define ecl_process_get_tls(key) pthread_getspecific(key) @@ -79,23 +93,197 @@ ecl_set_process_env(cl_env_ptr env) cl_env_ptr cl_env_p = NULL; #endif /* ECL_THREADS */ -/* -- Initialiation --------------------------------------------------------- */ +#ifdef ECL_THREADS +/* -- Thread local bindings */ +static void +init_tl_bindings(cl_object process, cl_env_ptr env) +{ + + cl_index bindings_size; + cl_object *bindings; + if (Null(process) || Null(process->process.inherit_bindings_p)) { + cl_index idx = 0, size = 256; + bindings_size = size; + bindings = (cl_object *)ecl_malloc(size*sizeof(cl_object*)); + for(idx=0; idx<256; idx++) { + bindings[idx] = ECL_NO_TL_BINDING; + } + } else { + cl_env_ptr parent_env = ecl_process_env(); + bindings_size = parent_env->bds_stack.tl_bindings_size; + bindings = (cl_object *)ecl_malloc(bindings_size*sizeof(cl_object*)); + ecl_copy(bindings, parent_env->bds_stack.tl_bindings, bindings_size*sizeof(cl_object*)); + } + env->bds_stack.tl_bindings_size = bindings_size; + env->bds_stack.tl_bindings = bindings; + +} +#endif + +/* -- Managing the collection of processes ---------------------------------- */ + +#ifdef ECL_THREADS + +/* Run a process in the current system thread. */ +cl_env_ptr +ecl_adopt_cpu() +{ + cl_env_ptr the_env = ecl_process_env_unsafe(); + if (the_env != NULL) + return the_env; + the_env = _ecl_alloc_env(0); + ecl_set_process_env(the_env); + the_env->own_process = ECL_NIL; + ecl_modules_init_env(the_env); + ecl_modules_init_cpu(the_env); + + return the_env; +} void -init_process(void) +ecl_disown_cpu() +{ + cl_env_ptr the_env = ecl_process_env_unsafe(); + if (the_env == NULL) + return; + ecl_modules_free_cpu(the_env); + ecl_modules_free_env(the_env); + _ecl_dealloc_env(the_env); +} + +#ifdef ECL_WINDOWS_THREADS +static DWORD WINAPI +#else +static void * +#endif +thread_entry_point(void *ptr) +{ + cl_env_ptr the_env = ecl_cast_ptr(cl_env_ptr, ptr); + cl_object process = the_env->own_process; + /* Setup the environment for the execution of the thread. */ + ecl_modules_init_cpu(the_env); + /* Start the user routine */ + process->process.entry(0); + ecl_disable_interrupts_env(the_env); + ecl_disown_cpu(); +#ifdef ECL_WINDOWS_THREADS + return 1; +#else + return NULL; +#endif +} + +/* Run a process in a new system thread. */ +cl_env_ptr +ecl_spawn_cpu(cl_object process) +{ + cl_env_ptr the_env = ecl_process_env(); + cl_env_ptr new_env = NULL; + int code = 0; + /* Allocate and initialize the new cpu env. */ + { + new_env = _ecl_alloc_env(the_env); + new_env->trap_fpe_bits = the_env->trap_fpe_bits; + new_env->own_process = process; + process->process.env = new_env; + ecl_modules_init_env(new_env); + } + /* Spawn the thread */ + ecl_disable_interrupts_env(the_env); +#if !defined(ECL_WINDOWS_THREADS) && defined(HAVE_SIGPROCMASK) + { + /* Block all asynchronous signals until the thread is completely set up. The + * synchronous signals SIGSEGV and SIGBUS are needed by the gc and and can't + * be blocked. */ + sigset_t new, previous; + sigfillset(&new); + sigdelset(&new, SIGSEGV); + sigdelset(&new, SIGBUS); + ecl_sigmask(SIG_BLOCK, &new, &previous); + code = ecl_thread_create(new_env, thread_entry_point); + ecl_sigmask(SIG_SETMASK, &previous, NULL); + } +#else + code = ecl_thread_create(new_env, thread_entry_point); +#endif + /* Deal with the fallout of the thread creation. */ + if (code != 0) { + process->process.env = NULL; + ecl_modules_free_env(new_env); + _ecl_dealloc_env(new_env); + } + ecl_enable_interrupts_env(the_env); + return code ? NULL : new_env; +} +#endif + +/* -- Module definition (so meta!) ------------------------------------------ */ +static cl_object +create_process() { - cl_env_ptr env = cl_core.first_env; #ifdef ECL_THREADS ecl_process_key_create(cl_env_key); - ecl_mutex_init(&cl_core.processes_lock, 1); - ecl_mutex_init(&cl_core.global_lock, 1); - ecl_mutex_init(&cl_core.error_lock, 1); - ecl_rwlock_init(&cl_core.global_env_lock); + ecl_mutex_init(&ecl_core.processes_lock, 1); + ecl_mutex_init(&ecl_core.global_lock, 1); + ecl_mutex_init(&ecl_core.error_lock, 1); + ecl_rwlock_init(&ecl_core.global_env_lock); + ecl_core.threads = ecl_make_stack(16); #endif - ecl_set_process_env(env); - env->default_sigmask = NULL; - env->method_cache = NULL; - env->slot_cache = NULL; - env->interrupt_struct = NULL; - env->disable_interrupts = 1; + return ECL_NIL; } + +static cl_object +init_env_process(cl_env_ptr the_env) +{ +#ifdef ECL_THREAD + init_tl_bindings(the_env->own_process, the_env); +#endif + return ECL_NIL; +} + +static cl_object +init_cpu_process(cl_env_ptr the_env) +{ +#ifdef ECL_THREADS + ecl_thread_t main_thread; + ecl_set_process_self(main_thread); + the_env->thread = main_thread; +#endif + ecl_set_process_env(the_env); + return ECL_NIL; +} + +static cl_object +free_cpu_process(cl_env_ptr the_env) +{ +#ifdef ECL_WINDOWS_THREADS + CloseHandle(the_env->thread); +#endif + ecl_set_process_env(NULL); + return ECL_NIL; +} + +static cl_object +free_env_process(cl_env_ptr the_env) +{ +#ifdef ECL_THREAD + the_env->own_process = ECL_NIL; +#endif + return ECL_NIL; +} + +ecl_def_ct_base_string(str_process, "PROCESS", 7, static, const); + +static struct ecl_module module_process = { + .name = str_process, + .create = create_process, + .enable = ecl_module_no_op, + .init_env = init_env_process, + .init_cpu = init_cpu_process, + .free_cpu = free_cpu_process, + .free_env = free_env_process, + .disable = ecl_module_no_op, + .destroy = ecl_module_no_op +}; + +cl_object ecl_module_process = (cl_object)&module_process; diff --git a/src/c/read.d b/src/c/read.d index 8343635b5b6a1488652d3e296ee5903a6845c32f..69a2efa65b488a2fb3bdce5b9acfeee6a01ee9ca 100644 --- a/src/c/read.d +++ b/src/c/read.d @@ -910,7 +910,7 @@ static cl_object sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) { cl_env_ptr env = ecl_process_env(); - cl_index sp = ECL_STACK_INDEX(env); + cl_index sp = ecl_vms_index(env); cl_object last, elt, x; cl_fixnum dim, dimcount, i; cl_object rtbl = ecl_current_readtable(); @@ -935,7 +935,7 @@ sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) FEreader_error("Character ~:C is not allowed after #*", in, 1, ECL_CODE_CHAR(x)); } - ECL_STACK_PUSH(env, ecl_make_fixnum(x == '1')); + ecl_vms_push(env, ecl_make_fixnum(x == '1')); } if (Null(d)) { dim = dimcount; @@ -951,16 +951,16 @@ sharp_asterisk_reader(cl_object in, cl_object c, cl_object d) unlikely_if (dim && (dimcount == 0)) FEreader_error("Cannot fill the bit-vector #*.", in, 0); } - last = ECL_STACK_REF(env,-1); + last = ECL_VMS_REF(env,-1); x = ecl_alloc_simple_vector(dim, ecl_aet_bit); for (i = 0; i < dim; i++) { - elt = (i < dimcount) ? env->stack[sp+i] : last; + elt = (i < dimcount) ? env->run_stack.org[sp+i] : last; if (elt == ecl_make_fixnum(0)) x->vector.self.bit[i/CHAR_BIT] &= ~(0200 >> i%CHAR_BIT); else x->vector.self.bit[i/CHAR_BIT] |= 0200 >> i%CHAR_BIT; } - ECL_STACK_POP_N_UNSAFE(env, dimcount); + ecl_vms_drop(env, dimcount); @(return x); } @@ -1277,8 +1277,8 @@ patch_sharp(const cl_env_ptr the_env, cl_object x) } else { cl_object table = cl__make_hash_table(@'eq', ecl_make_fixnum(20), /* size */ - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); do { cl_object pair = ECL_CONS_CAR(pairs); _ecl_sethash(pair, table, ECL_CONS_CDR(pair)); @@ -1718,7 +1718,7 @@ do_read_delimited_list(int d, cl_object in, bool proper_list) @(return ECL_CODE_CHAR(c)); } } else if (f == ECL_LISTEN_NO_CHAR) { - @(return @'nil'); + @(return ECL_NIL); } /* We reach here if there was an EOF */ END_OF_FILE: @@ -1859,8 +1859,8 @@ ecl_readtable_set(cl_object readtable, int c, enum ecl_chattrib cat, cl_object hash = readtable->readtable.hash; if (Null(hash)) { hash = cl__make_hash_table(@'eql', ecl_make_fixnum(128), - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); readtable->readtable.hash = hash; } _ecl_sethash(ECL_CODE_CHAR(c), hash, @@ -1937,8 +1937,8 @@ ecl_invalid_character_p(int c) c = ecl_char_code(chr); cat = Null(non_terminating_p)? cat_terminating : cat_non_terminating; table = cl__make_hash_table(@'eql', ecl_make_fixnum(128), - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); ecl_readtable_set(readtable, c, cat, table); @(return ECL_T); @) diff --git a/src/c/serialize.d b/src/c/serialize.d index c77ce56e9342a5705431f9e8c17bf89c68892d72..ac829031bbb1fc9543245cc1cbe4c15cec5a22e0 100644 --- a/src/c/serialize.d +++ b/src/c/serialize.d @@ -76,6 +76,8 @@ static cl_index object_size[] = { ROUNDED_SIZE(ecl_codeblock), /* t_codeblock */ ROUNDED_SIZE(ecl_foreign), /* t_foreign */ ROUNDED_SIZE(ecl_stack_frame), /* t_frame */ + ROUNDED_SIZE(ecl_exception), /* t_exception */ + ROUNDED_SIZE(ecl_module), /* t_module */ ROUNDED_SIZE(ecl_weak_pointer) /* t_weak_pointer */ #ifdef ECL_SSE2 , ROUNDED_SIZE(ecl_sse_pack) /* t_sse_pack */ @@ -349,8 +351,8 @@ init_pool(pool_t pool, cl_object root) ECL_NIL, ecl_make_fixnum(0)); pool->hash = cl__make_hash_table(@'eql', ecl_make_fixnum(256), - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); ecl_sethash(root, pool->hash, ecl_make_fixnum(0)); pool->queue = ecl_list1(root); pool->last = pool->queue; diff --git a/src/c/stack2.d b/src/c/stack2.d new file mode 100644 index 0000000000000000000000000000000000000000..c3d003d67fdf96afc04b115f2e91e29b631ed5d5 --- /dev/null +++ b/src/c/stack2.d @@ -0,0 +1,236 @@ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ + +/* + * stacks.d - runtime, binding, history and frame stacks + * + * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya + * Copyright (c) 1990 Giuseppe Attardi + * Copyright (c) 2001 Juan Jose Garcia Ripoll + * + * See file 'LICENSE' for the copyright details. + * + */ + +#include +#include +#include +#include +#ifdef HAVE_SYS_RESOURCE_H +# include +# include +#endif +#include +#include +#include +#include + +/* -- Bindings stack -------------------------------------------------------- */ + +static ecl_bds_ptr +get_bds_ptr(cl_object x) +{ + if (ECL_FIXNUMP(x)) { + cl_env_ptr env = ecl_process_env(); + ecl_bds_ptr p = env->bds_stack.org + ecl_fixnum(x); + if (env->bds_stack.org <= p && p <= env->bds_stack.top) + return(p); + } + FEerror("~S is an illegal bds index.", 1, x); +} + +cl_object +si_bds_top() +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, ecl_make_fixnum(env->bds_stack.top - env->bds_stack.org)); +} + +cl_object +si_bds_var(cl_object arg) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, get_bds_ptr(arg)->symbol); +} + +cl_object +si_bds_val(cl_object arg) +{ + cl_env_ptr env = ecl_process_env(); + cl_object v = get_bds_ptr(arg)->value; + ecl_return1(env, ((v == OBJNULL || v == ECL_NO_TL_BINDING)? ECL_UNBOUND : v)); +} + +/* -- Frame stack ----------------------------------------------------------- */ + +static ecl_frame_ptr +get_frame_ptr(cl_object x) +{ + if (ECL_FIXNUMP(x)) { + cl_env_ptr env = ecl_process_env(); + ecl_frame_ptr p = env->frs_stack.org + ecl_fixnum(x); + if (env->frs_stack.org <= p && p <= env->frs_stack.top) + return p; + } + FEerror("~S is an illegal frs index.", 1, x); +} + +cl_object +si_frs_top() +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, ecl_make_fixnum(env->frs_stack.top - env->frs_stack.org)); +} + +cl_object +si_frs_bds(cl_object arg) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_bds_ndx)); +} + +cl_object +si_frs_tag(cl_object arg) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, get_frame_ptr(arg)->frs_val); +} + +cl_object +si_frs_ihs(cl_object arg) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_ihs->index)); +} + +cl_object +si_sch_frs_base(cl_object fr, cl_object ihs) +{ + cl_env_ptr env = ecl_process_env(); + ecl_frame_ptr x; + cl_index y = ecl_to_size(ihs); + for (x = get_frame_ptr(fr); + x <= env->frs_stack.top && x->frs_ihs->index < y; + x++); + ecl_return1(env, ((x > env->frs_stack.top) + ? ECL_NIL + : ecl_make_fixnum(x - env->frs_stack.org))); +} + +/* -- Invocation stack ------------------------------------------------------ */ + +static ecl_ihs_ptr +get_ihs_ptr(cl_index n) +{ + cl_env_ptr env = ecl_process_env(); + ecl_ihs_ptr p = env->ihs_stack.top; + if (n > p->index) + FEerror("~D is an illegal IHS index.", 1, ecl_make_fixnum(n)); + while (n < p->index) + p = p->next; + return p; +} + +cl_object +si_ihs_top(void) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, ecl_make_fixnum(env->ihs_stack.top->index)); +} + +cl_object +si_ihs_prev(cl_object x) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, cl_1M(x)); +} + +cl_object +si_ihs_next(cl_object x) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, cl_1P(x)); +} + +cl_object +si_ihs_bds(cl_object arg) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, ecl_make_fixnum(get_ihs_ptr(ecl_to_size(arg))->bds)); +} + +cl_object +si_ihs_fun(cl_object arg) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->function); +} + +cl_object +si_ihs_env(cl_object arg) +{ + cl_env_ptr env = ecl_process_env(); + ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->lex_env); +} + +/* -- Lisp ops on stacks ---------------------------------------------------- */ + +cl_object +si_set_limit(cl_object type, cl_object limit) +{ + cl_env_ptr env = ecl_process_env(); + cl_index margin; + if (type == @'ext::frame-stack') { + cl_index current_size = env->frs_stack.top - env->frs_stack.org; + cl_index request_size = ecl_to_size(limit); + if(current_size > request_size) + FEerror("Cannot shrink FRS stack below ~D.", 1, limit); + ecl_frs_set_limit(env, request_size); + } else if (type == @'ext::binding-stack') { + cl_index current_size = env->bds_stack.top - env->bds_stack.org; + cl_index request_size = ecl_to_size(limit); + if(current_size > request_size) + FEerror("Cannot shrink BDS stack below ~D.", 1, limit); + ecl_bds_set_limit(env, request_size); + } else if (type == @'ext::lisp-stack') { + cl_index current_size = env->run_stack.top - env->run_stack.org; + cl_index request_size = ecl_to_size(limit); + if(current_size > request_size) + FEerror("Cannot shrink VMS stack below ~D.", 1, limit); + ecl_vms_set_limit(env, request_size); + } else if (type == @'ext::c-stack') { + cl_index the_size = ecl_to_size(limit); + margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; + ecl_cs_set_size(env, the_size + 2*margin); + } else if (type == @'ext::heap-size') { + /* + * size_t can be larger than cl_index, and ecl_to_size() + * creates a fixnum which is too small for size_t on 32-bit. + */ + size_t the_size = (size_t)ecl_to_ulong(limit); + _ecl_set_max_heap_size(the_size); + } + + ecl_return1(env, si_get_limit(type)); +} + +cl_object +si_get_limit(cl_object type) +{ + cl_env_ptr env = ecl_process_env(); + cl_index output = 0; + if (type == @'ext::frame-stack') + output = env->frs_stack.limit_size; + else if (type == @'ext::binding-stack') + output = env->bds_stack.limit_size; + else if (type == @'ext::lisp-stack') + output = env->run_stack.limit_size; + else if (type == @'ext::c-stack') + output = env->c_stack.limit_size; + else if (type == @'ext::heap-size') { + /* size_t can be larger than cl_index */ + ecl_return1(env, ecl_make_unsigned_integer(ecl_core.max_heap_size)); + } + + ecl_return1(env, ecl_make_unsigned_integer(output)); +} diff --git a/src/c/stacks.d b/src/c/stacks.d index 3c883a59d2344761cc555aa8d831bcd39d83a293..ea12de46c67ef62d70a1eda932a73385641ee33b 100644 --- a/src/c/stacks.d +++ b/src/c/stacks.d @@ -2,7 +2,7 @@ /* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ /* - * stacks.d - binding/history/frame stacks + * stacks.d - runtime, binding, history and frame stacks * * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya * Copyright (c) 1990 Giuseppe Attardi @@ -13,28 +13,35 @@ */ #include +#include #include #include #ifdef HAVE_SYS_RESOURCE_H # include # include #endif +#include +#include #include #include -/* ------------------------- C STACK ---------------------------------- */ - -static void -cs_set_size(cl_env_ptr env, cl_index new_size) +/* -- C Stack ---------------------------------------------------------------- */ +void +ecl_cs_init(cl_env_ptr env) { volatile char foo = 0; cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; -#if defined(ECL_CAN_SET_STACK_SIZE) + cl_index new_size = ecl_option_values[ECL_OPT_C_STACK_SIZE]; + cl_index max_size = new_size; + if (env->c_stack.org == NULL) { + /* Rough estimate. Not very safe. We assume that cl_boot() is invoked from + * the main() routine of the program. */ + env->c_stack.org = (char*)(&env); + } +#ifdef ECL_CAN_SET_STACK_SIZE { struct rlimit rl; - if (!getrlimit(RLIMIT_STACK, &rl)) { - env->cs_max_size = rl.rlim_max; if (new_size > rl.rlim_cur) { rl.rlim_cur = (new_size > rl.rlim_max) ? rl.rlim_max : new_size; if (setrlimit(RLIMIT_STACK, &rl)) @@ -42,39 +49,92 @@ cs_set_size(cl_env_ptr env, cl_index new_size) } } else { rl.rlim_cur = new_size; + rl.rlim_max = max_size; } if (rl.rlim_cur == 0 || rl.rlim_cur == RLIM_INFINITY || rl.rlim_cur > (cl_index)(-1)) { - /* Either getrlimit failed or returned nonsense, either way we - * don't know the stack size. Use a default of 1 MB and hope for - * the best. */ + /* Either getrlimit failed or returned nonsense, either way we don't + * know the stack size. Use a default of 1 MB and hope for the best. */ new_size = 1048576; + max_size = 1048576; } else { new_size = rl.rlim_cur; + max_size = rl.rlim_max; } + } +#endif + env->c_stack.limit_size = new_size - 2*margin; + env->c_stack.size = new_size; + env->c_stack.max_size = max_size; #ifdef ECL_DOWN_STACK - env->cs_barrier = env->cs_org - new_size; + env->c_stack.max = env->c_stack.org - new_size; + if (&foo > (env->c_stack.org - new_size) + 16) { + env->c_stack.limit = (env->c_stack.org - new_size) + (2*margin); + if (env->c_stack.limit < env->c_stack.max) + env->c_stack.max = env->c_stack.limit; + } else { + ecl_internal_error("Can't set the size of the C stack: sanity check failed."); + } #else - env->cs_barrier = env->cs_org + new_size; + env->c_stack.max = env->c_stack.org + new_size; + if (&foo < (env->c_stack.org + new_size) - 16) { + env->c_stack.limit = (env->c_stack.org + new_size) - (2*margin); + if (env->c_stack.limit > env->c_stack.max) + env->c_stack.max = env->c_stack.limit; + } else { + ecl_internal_error("Can't set the size of the C stack: sanity check failed."); + } #endif +} + +void +ecl_cs_set_size(cl_env_ptr env, cl_index new_size) +{ + volatile char foo = 0; + cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; + if (new_size > env->c_stack.max_size) + new_size = env->c_stack.max_size; +#ifdef ECL_CAN_SET_STACK_SIZE + { + struct rlimit rl; + if (!getrlimit(RLIMIT_STACK, &rl)) { + if (new_size > rl.rlim_cur) { + rl.rlim_cur = (new_size > rl.rlim_max) ? rl.rlim_max : new_size; + if (setrlimit(RLIMIT_STACK, &rl)) + ecl_internal_error("Can't set the size of the C stack"); + } + } else { + rl.rlim_cur = new_size; + } + if (rl.rlim_cur == 0 || rl.rlim_cur == RLIM_INFINITY || rl.rlim_cur > (cl_index)(-1)) { + /* Either getrlimit failed or returned nonsense, either way we don't know + * the stack size. Use a default of 1 MB and hope for the best. */ + new_size = 1048576; + } else { + new_size = rl.rlim_cur; + } } #endif - env->cs_limit_size = new_size - (2*margin); + env->c_stack.limit_size = new_size - 2*margin; + env->c_stack.size = new_size; #ifdef ECL_DOWN_STACK - if (&foo > (env->cs_org - new_size) + 16) { - env->cs_limit = (env->cs_org - new_size) + (2*margin); - if (env->cs_limit < env->cs_barrier) - env->cs_barrier = env->cs_limit; + env->c_stack.max = env->c_stack.org - new_size; + if (&foo > (env->c_stack.org - new_size) + 16) { + env->c_stack.limit = (env->c_stack.org - new_size) + (2*margin); + if (env->c_stack.limit < env->c_stack.max) + env->c_stack.max = env->c_stack.limit; + } else { + ecl_internal_error("Can't set the size of the C stack: sanity check failed."); } #else - if (&foo < (env->cs_org + new_size) - 16) { - env->cs_limit = (env->cs_org + new_size) - (2*margin); - if (env->cs_limit > env->cs_barrier) - env->cs_barrier = env->cs_limit; + env->c_stack.max = env->c_stack.org + new_size; + if (&foo < (env->c_stack.org + new_size) - 16) { + env->c_stack.limit = (env->c_stack.org + new_size) - (2*margin); + if (env->c_stack.limit > env->c_stack.max) + env->c_stack.max = env->c_stack.limit; + } else { + ecl_internal_error("Can't set the size of the C stack: sanity check failed."); } #endif - else - ecl_internal_error("Can't set the size of the C stack: sanity check failed"); - env->cs_size = new_size; } void @@ -86,143 +146,105 @@ ecl_cs_overflow(void) ";;;\n\n"; cl_env_ptr env = ecl_process_env(); cl_index margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; - cl_index size = env->cs_size; + cl_index size = env->c_stack.size; #ifdef ECL_DOWN_STACK - if (env->cs_limit > env->cs_org - size) - env->cs_limit -= margin; + if (env->c_stack.limit > env->c_stack.org - size) + env->c_stack.limit -= margin; #else - if (env->cs_limit < env->cs_org + size) - env->cs_limit += margin; + if (env->c_stack.limit < env->c_stack.org + size) + env->c_stack.limit += margin; #endif else - ecl_unrecoverable_error(env, stack_overflow_msg); - - if (env->cs_max_size == (cl_index)0 || env->cs_size < env->cs_max_size) - si_serror(6, @"Extend stack size", - @'ext::stack-overflow', - @':size', ecl_make_fixnum(size), - @':type', @'ext::c-stack'); - else - si_serror(6, ECL_NIL, - @'ext::stack-overflow', - @':size', ECL_NIL, - @':type', @'ext::c-stack'); - size += size/2; - if (size > env->cs_max_size) - size = env->cs_max_size; - cs_set_size(env, size); -} - -void -ecl_cs_set_org(cl_env_ptr env) -{ -#ifdef GBC_BOEHM - struct GC_stack_base base; - if (GC_get_stack_base(&base) == GC_SUCCESS) - env->cs_org = (char*)base.mem_base; + ecl_internal_error(stack_overflow_msg); + if (env->c_stack.max_size == (cl_index)0 || env->c_stack.size < env->c_stack.max_size) + ecl_cerror(ECL_EX_CS_OVR, ecl_make_fixnum(size), ECL_T); else -#endif - { - /* Rough estimate. Not very safe. We assume that cl_boot() - * is invoked from the main() routine of the program. - */ - env->cs_org = (char*)(&env); - } - env->cs_barrier = env->cs_org; - env->cs_max_size = 0; - cs_set_size(env, ecl_option_values[ECL_OPT_C_STACK_SIZE]); + ecl_ferror(ECL_EX_CS_OVR, ecl_make_fixnum(size), ECL_NIL); } -/* ------------------------- LISP STACK ------------------------------- */ - -cl_object * -ecl_stack_set_size(cl_env_ptr env, cl_index tentative_new_size) -{ - cl_index top = env->stack_top - env->stack; - cl_object *new_stack, *old_stack; - cl_index safety_area = ecl_option_values[ECL_OPT_LISP_STACK_SAFETY_AREA]; - cl_index new_size = tentative_new_size + 2*safety_area; - - /* Round to page size */ - new_size = ((new_size + LISP_PAGESIZE - 1) / LISP_PAGESIZE) * LISP_PAGESIZE; - - if (ecl_unlikely(top > new_size)) { - FEerror("Internal error: cannot shrink stack below stack top.",0); - } - - old_stack = env->stack; - new_stack = (cl_object *)ecl_alloc_atomic(new_size * sizeof(cl_object)); - - ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); - memcpy(new_stack, old_stack, env->stack_size * sizeof(cl_object)); - env->stack_size = new_size; - env->stack_limit_size = new_size - 2*safety_area; - env->stack = new_stack; - env->stack_top = env->stack + top; - env->stack_limit = env->stack + (new_size - 2*safety_area); +/* -- ByteVM stack ----------------------------------------------------------- */ +static void +run_init(cl_env_ptr env) +{ + cl_index size, limit_size, margin; + margin = ecl_option_values[ECL_OPT_LISP_STACK_SAFETY_AREA]; + limit_size = ecl_option_values[ECL_OPT_LISP_STACK_SIZE]; + size = limit_size + 2 * margin; + env->run_stack.org = (cl_object *)ecl_malloc(size * sizeof(cl_object)); + env->run_stack.top = env->run_stack.org; + env->run_stack.limit = &env->run_stack.org[limit_size]; + env->run_stack.size = size; + env->run_stack.limit_size = limit_size; /* A stack always has at least one element. This is assumed by cl__va_start - * and friends, which take a sp=0 to have no arguments. - */ - if (top == 0) { - *(env->stack_top++) = ecl_make_fixnum(0); - } - ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); - - ecl_dealloc(old_stack); - return env->stack_top; + and friends, which take a sp=0 to have no arguments. */ + *(env->run_stack.top++) = ecl_make_fixnum(0); } void -FEstack_underflow(void) -{ - FEerror("Internal error: stack underflow.",0); -} - -void -FEstack_advance(void) -{ - FEerror("Internal error: stack advance beyond current point.",0); +ecl_vms_set_limit(cl_env_ptr env, cl_index new_lim_size) +{ + cl_index margin = ecl_option_values[ECL_OPT_LISP_STACK_SAFETY_AREA]; + cl_object *old_org = env->run_stack.org; + cl_object *new_org = NULL; + cl_index osize = env->run_stack.size; + cl_index nsize = new_lim_size + 2*margin; + cl_index current_size = env->run_stack.top - old_org; + if (current_size > new_lim_size) + ecl_internal_error("Cannot shrink frame stack below its minimal element"); + new_org = ecl_realloc(old_org, + osize * sizeof(*old_org), + nsize * sizeof(*old_org)); + ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); + env->run_stack.org = new_org; + env->run_stack.top = new_org + current_size; + env->run_stack.limit = new_org + new_lim_size; + /* Update indexes */ + env->run_stack.size = nsize; + env->run_stack.limit_size = new_lim_size; + ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); } cl_object * -ecl_stack_grow(cl_env_ptr env) +ecl_vms_extend(cl_env_ptr env) { - return ecl_stack_set_size(env, env->stack_size + env->stack_size / 2); + ecl_vms_set_limit(env, env->run_stack.limit_size + env->run_stack.limit_size / 2); + return env->run_stack.top; } cl_index -ecl_stack_push_values(cl_env_ptr env) { +ecl_vms_push_values(cl_env_ptr env) { cl_index i = env->nvalues; - cl_object *b = env->stack_top; + cl_object *b = env->run_stack.top; cl_object *p = b + i; - if (p >= env->stack_limit) { - b = ecl_stack_grow(env); + if (p >= env->run_stack.limit) { + b = ecl_vms_extend(env); p = b + i; } - env->stack_top = p; - memcpy(b, env->values, i * sizeof(cl_object)); + env->run_stack.top = p; + ecl_copy(b, env->values, i * sizeof(cl_object)); return i; } void -ecl_stack_pop_values(cl_env_ptr env, cl_index n) { - cl_object *p = env->stack_top - n; - if (ecl_unlikely(p < env->stack)) - FEstack_underflow(); +ecl_vms_pop_values(cl_env_ptr env, cl_index n) { + cl_object *p = env->run_stack.top - n; + if (ecl_unlikely(p < env->run_stack.org)) + ecl_internal_error("vms: stack underflow."); env->nvalues = n; - env->stack_top = p; - memcpy(env->values, p, n * sizeof(cl_object)); + env->run_stack.top = p; + ecl_copy(env->values, p, n * sizeof(cl_object)); } cl_object ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size) { - cl_object *base = env->stack_top; + cl_object *base = env->run_stack.top; cl_index bindex; if (size) { - if ((env->stack_limit - base) < size) { - base = ecl_stack_set_size(env, env->stack_size + size); + if ((env->run_stack.limit - base) < size) { + ecl_vms_set_limit(env, env->run_stack.limit_size + size); + base = env->run_stack.top; } } bindex = ECL_STACK_INDEX(env); @@ -232,7 +254,7 @@ ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size) f->frame.size = size; f->frame.sp = bindex; f->frame.env = env; - env->stack_top = (base + size); + env->run_stack.top = (base + size); return f; } @@ -240,11 +262,11 @@ void ecl_stack_frame_push(cl_object f, cl_object o) { cl_env_ptr env = f->frame.env; - cl_object *top = env->stack_top; - if (top >= env->stack_limit) { - top = ecl_stack_grow(env); + cl_object *top = env->run_stack.top; + if (top >= env->run_stack.limit) { + top = ecl_vms_extend(env); } - env->stack_top = ++top; + env->run_stack.top = ++top; *(top-1) = o; f->frame.size++; } @@ -253,7 +275,7 @@ void ecl_stack_frame_push_values(cl_object f) { cl_env_ptr env = f->frame.env; - ecl_stack_push_values(env); + ecl_vms_push_values(env); f->frame.size += env->nvalues; } @@ -276,45 +298,27 @@ ecl_stack_frame_close(cl_object f) { if (f->frame.opened) { f->frame.opened = 0; - ECL_STACK_SET_INDEX(f->frame.env, f->frame.base); + ecl_vms_unwind(f->frame.env, f->frame.base); } } -/* ------------------------- BINDING STACK ---------------------------- */ - -void -ecl_bds_unwind_n(cl_env_ptr env, int n) -{ - while (n--) ecl_bds_unwind1(env); -} +/* -- Binding stack ---------------------------------------------------------- */ static void -ecl_bds_set_size(cl_env_ptr env, cl_index new_size) +bds_init(cl_env_ptr env) { - ecl_bds_ptr old_org = env->bds_org; - cl_index limit = env->bds_top - old_org; - if (new_size <= limit) { - FEerror("Cannot shrink the binding stack below ~D.", 1, - ecl_make_unsigned_integer(limit)); - } else { - cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - ecl_bds_ptr org; - env->bds_limit_size = new_size - 2*margin; - org = ecl_alloc_atomic(new_size * sizeof(*org)); - - ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); - memcpy(org, old_org, (limit + 1) * sizeof(*org)); - env->bds_top = org + limit; - env->bds_org = org; - env->bds_limit = org + (new_size - 2*margin); - env->bds_size = new_size; - ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); - - ecl_dealloc(old_org); - } + cl_index size, margin, limit_size; + margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; + limit_size = ecl_option_values[ECL_OPT_BIND_STACK_SIZE]; + size = limit_size + 2 * margin; + env->bds_stack.org = (ecl_bds_ptr)ecl_malloc(size * sizeof(*env->bds_stack.org)); + env->bds_stack.top = env->bds_stack.org-1; + env->bds_stack.limit = &env->bds_stack.org[limit_size]; + env->bds_stack.size = size; + env->bds_stack.limit_size = limit_size; } -ecl_bds_ptr +ecl_bds_ptr ecl_bds_overflow(void) { static const char *stack_overflow_msg = @@ -323,93 +327,36 @@ ecl_bds_overflow(void) ";;;\n\n"; cl_env_ptr env = ecl_process_env(); cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - cl_index size = env->bds_size; - ecl_bds_ptr org = env->bds_org; + cl_index size = env->bds_stack.size; + cl_index limit_size = env->bds_stack.limit_size; + ecl_bds_ptr org = env->bds_stack.org; ecl_bds_ptr last = org + size; - if (env->bds_limit >= last) { - ecl_unrecoverable_error(env, stack_overflow_msg); + if (env->bds_stack.limit >= last) { + ecl_internal_error(stack_overflow_msg); } - env->bds_limit += margin; - si_serror(6, @"Extend stack size", - @'ext::stack-overflow', @':size', ecl_make_fixnum(size), - @':type', @'ext::binding-stack'); - ecl_bds_set_size(env, size + (size / 2)); - return env->bds_top; + env->bds_stack.limit += margin; + ecl_cerror(ECL_EX_BDS_OVR, ecl_make_fixnum(limit_size), ECL_T); + return env->bds_stack.top; } void -ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_top_index) +ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_ndx) { - ecl_bds_ptr new_bds_top = new_bds_top_index + env->bds_org; - ecl_bds_ptr bds = env->bds_top; + ecl_bds_ptr new_bds_top = env->bds_stack.org + new_bds_ndx; + ecl_bds_ptr bds = env->bds_stack.top; for (; bds > new_bds_top; bds--) #ifdef ECL_THREADS ecl_bds_unwind1(env); #else bds->symbol->symbol.value = bds->value; #endif - env->bds_top = new_bds_top; + env->bds_stack.top = new_bds_top; } -cl_index -ecl_progv(cl_env_ptr env, cl_object vars0, cl_object values0) -{ - cl_object vars = vars0, values = values0; - cl_index n = env->bds_top - env->bds_org; - for (; LISTP(vars) && LISTP(values); vars = ECL_CONS_CDR(vars)) { - if (Null(vars)) { - return n; - } else { - cl_object var = ECL_CONS_CAR(vars); - if (!ECL_SYMBOLP(var)) - FEillegal_variable_name(var); - if (ecl_symbol_type(var) & ecl_stp_constant) - FEbinding_a_constant(var); - if (Null(values)) { - ecl_bds_bind(env, var, OBJNULL); - } else { - ecl_bds_bind(env, var, ECL_CONS_CAR(values)); - values = ECL_CONS_CDR(values); - } - } - } - FEerror("Wrong arguments to special form PROGV. Either~%" - "~A~%or~%~A~%are not proper lists", - 2, vars0, values0); -} - -static ecl_bds_ptr -get_bds_ptr(cl_object x) -{ - if (ECL_FIXNUMP(x)) { - cl_env_ptr env = ecl_process_env(); - ecl_bds_ptr p = env->bds_org + ecl_fixnum(x); - if (env->bds_org <= p && p <= env->bds_top) - return(p); - } - FEerror("~S is an illegal bds index.", 1, x); -} - -cl_object -si_bds_top() -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(env->bds_top - env->bds_org)); -} - -cl_object -si_bds_var(cl_object arg) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, get_bds_ptr(arg)->symbol); -} - -cl_object -si_bds_val(cl_object arg) +void +ecl_bds_unwind_n(cl_env_ptr env, int n) { - cl_env_ptr env = ecl_process_env(); - cl_object v = get_bds_ptr(arg)->value; - ecl_return1(env, ((v == OBJNULL || v == ECL_NO_TL_BINDING)? ECL_UNBOUND : v)); + while (n--) ecl_bds_unwind1(env); } #ifdef ecl_bds_bind @@ -430,28 +377,17 @@ ecl_new_binding_index(cl_env_ptr env, cl_object symbol) cl_object pool; cl_index new_index = symbol->symbol.binding; if (new_index == ECL_MISSING_SPECIAL_BINDING) { - pool = ecl_atomic_pop(&cl_core.reused_indices); + pool = ecl_atomic_pop(&ecl_core.reused_indices); if (!Null(pool)) { new_index = ecl_fixnum(ECL_CONS_CAR(pool)); } else { - new_index = ecl_atomic_index_incf(&cl_core.last_var_index); + new_index = ecl_atomic_index_incf(&ecl_core.last_var_index); } symbol->symbol.binding = new_index; } return new_index; } -static cl_object -ecl_extend_bindings_array(cl_object vector) -{ - cl_index new_size = cl_core.last_var_index * 1.25; - cl_object new_vector = si_make_vector(ECL_T, ecl_make_fixnum(new_size), ECL_NIL, - ECL_NIL, ECL_NIL, ECL_NIL); - si_fill_array_with_elt(new_vector, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); - ecl_copy_subarray(new_vector, 0, vector, 0, vector->vector.dim); - return new_vector; -} - static cl_index invalid_or_too_large_binding_index(cl_env_ptr env, cl_object s) { @@ -459,11 +395,18 @@ invalid_or_too_large_binding_index(cl_env_ptr env, cl_object s) if (index == ECL_MISSING_SPECIAL_BINDING) { index = ecl_new_binding_index(env, s); } - if (index >= env->thread_local_bindings_size) { - cl_object vector = env->bindings_array; - env->bindings_array = vector = ecl_extend_bindings_array(vector); - env->thread_local_bindings_size = vector->vector.dim; - env->thread_local_bindings = vector->vector.self.t; + if (index >= env->bds_stack.tl_bindings_size) { + cl_index osize = env->bds_stack.tl_bindings_size; + cl_index nsize = ecl_core.last_var_index * 1.25; + cl_object *old_vector = env->bds_stack.tl_bindings; + cl_object *new_vector = ecl_realloc(old_vector, + osize*sizeof(cl_object*), + nsize*sizeof(cl_object*)); + while(osize < nsize) { + new_vector[osize++] = ECL_NO_TL_BINDING; + } + env->bds_stack.tl_bindings = new_vector; + env->bds_stack.tl_bindings_size = nsize; } return index; } @@ -479,15 +422,15 @@ ecl_bds_bind(cl_env_ptr env, cl_object s, cl_object v) cl_object *location; ecl_bds_ptr slot; cl_index index = s->symbol.binding; - if (index >= env->thread_local_bindings_size) { + if (index >= env->bds_stack.tl_bindings_size) { index = invalid_or_too_large_binding_index(env,s); } - location = env->thread_local_bindings + index; - slot = env->bds_top+1; - if (slot >= env->bds_limit) slot = ecl_bds_overflow(); + location = env->bds_stack.tl_bindings + index; + slot = env->bds_stack.top+1; + if (slot >= env->bds_stack.limit) slot = ecl_bds_overflow(); slot->symbol = ECL_DUMMY_TAG; AO_nop_full(); - ++env->bds_top; + ++env->bds_stack.top; ecl_disable_interrupts_env(env); slot->symbol = s; slot->value = *location; @@ -495,7 +438,7 @@ ecl_bds_bind(cl_env_ptr env, cl_object s, cl_object v) ecl_enable_interrupts_env(env); #else ecl_bds_check(env); - ecl_bds_ptr slot = ++(env->bds_top); + ecl_bds_ptr slot = ++(env->bds_stack.top); ecl_disable_interrupts_env(env); slot->symbol = s; slot->value = s->symbol.value; @@ -511,15 +454,15 @@ ecl_bds_push(cl_env_ptr env, cl_object s) cl_object *location; ecl_bds_ptr slot; cl_index index = s->symbol.binding; - if (index >= env->thread_local_bindings_size) { + if (index >= env->bds_stack.tl_bindings_size) { index = invalid_or_too_large_binding_index(env,s); } - location = env->thread_local_bindings + index; - slot = env->bds_top+1; - if (slot >= env->bds_limit) slot = ecl_bds_overflow(); + location = env->bds_stack.tl_bindings + index; + slot = env->bds_stack.top+1; + if (slot >= env->bds_stack.limit) slot = ecl_bds_overflow(); slot->symbol = ECL_DUMMY_TAG; AO_nop_full(); - ++env->bds_top; + ++env->bds_stack.top; ecl_disable_interrupts_env(env); slot->symbol = s; slot->value = *location; @@ -527,7 +470,7 @@ ecl_bds_push(cl_env_ptr env, cl_object s) ecl_enable_interrupts_env(env); #else ecl_bds_check(env); - ecl_bds_ptr slot = ++(env->bds_top); + ecl_bds_ptr slot = ++(env->bds_stack.top); ecl_disable_interrupts_env(env); slot->symbol = s; slot->value = s->symbol.value; @@ -538,14 +481,14 @@ ecl_bds_push(cl_env_ptr env, cl_object s) void ecl_bds_unwind1(cl_env_ptr env) { - cl_object s = env->bds_top->symbol; + cl_object s = env->bds_stack.top->symbol; #ifdef ECL_THREADS - cl_object *location = env->thread_local_bindings + s->symbol.binding; - *location = env->bds_top->value; + cl_object *location = env->bds_stack.tl_bindings + s->symbol.binding; + *location = env->bds_stack.top->value; #else - s->symbol.value = env->bds_top->value; + s->symbol.value = env->bds_stack.top->value; #endif - --env->bds_top; + --env->bds_stack.top; } #ifdef ECL_THREADS @@ -553,8 +496,8 @@ cl_object ecl_bds_read(cl_env_ptr env, cl_object s) { cl_index index = s->symbol.binding; - if (index < env->thread_local_bindings_size) { - cl_object x = env->thread_local_bindings[index]; + if (index < env->bds_stack.tl_bindings_size) { + cl_object x = env->bds_stack.tl_bindings[index]; if (x != ECL_NO_TL_BINDING) return x; } return s->symbol.value; @@ -564,8 +507,8 @@ cl_object * ecl_bds_ref(cl_env_ptr env, cl_object s) { cl_index index = s->symbol.binding; - if (index < env->thread_local_bindings_size) { - cl_object *location = env->thread_local_bindings + index; + if (index < env->bds_stack.tl_bindings_size) { + cl_object *location = env->bds_stack.tl_bindings + index; if (*location != ECL_NO_TL_BINDING) return location; } @@ -579,92 +522,83 @@ ecl_bds_set(cl_env_ptr env, cl_object s, cl_object value) } #endif /* ECL_THREADS */ -/* ------------------------- INVOCATION STACK ------------------------- */ - -static ecl_ihs_ptr -get_ihs_ptr(cl_index n) -{ - cl_env_ptr env = ecl_process_env(); - ecl_ihs_ptr p = env->ihs_top; - if (n > p->index) - FEerror("~D is an illegal IHS index.", 1, ecl_make_fixnum(n)); - while (n < p->index) - p = p->next; - return p; -} - -cl_object -si_ihs_top(void) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(env->ihs_top->index)); -} - -cl_object -si_ihs_prev(cl_object x) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, cl_1M(x)); -} - -cl_object -si_ihs_next(cl_object x) +void +ecl_bds_set_limit(cl_env_ptr env, cl_index new_lim_size) { - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, cl_1P(x)); + cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; + ecl_bds_ptr old_org = env->bds_stack.org; + ecl_bds_ptr new_org = NULL; + cl_index osize = env->bds_stack.size; + cl_index nsize = new_lim_size + 2*margin; + cl_index current_size = env->bds_stack.top - old_org; + if (current_size > new_lim_size) + ecl_internal_error("Cannot shrink frame stack below its minimal element"); + new_org = ecl_realloc(old_org, + osize * sizeof(*old_org), + nsize * sizeof(*old_org)); + ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); + env->bds_stack.org = new_org; + env->bds_stack.top = new_org + current_size; + env->bds_stack.limit = new_org + new_lim_size; + /* Update indexes */ + env->bds_stack.size = nsize; + env->bds_stack.limit_size = new_lim_size; + ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); } -cl_object -si_ihs_bds(cl_object arg) +/* -- Invocation stack ------------------------------------------------------- */ +static void +ihs_init(cl_env_ptr env) { - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(get_ihs_ptr(ecl_to_size(arg))->bds)); + static struct ecl_ihs_frame ihs_org = { NULL, NULL, NULL, 0}; + env->ihs_stack.top = &ihs_org; + ihs_org.function = ECL_NIL; + ihs_org.lex_env = ECL_NIL; + ihs_org.index = 0; } -cl_object -si_ihs_fun(cl_object arg) -{ - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->function); -} +/* -- Frame stack ------------------------------------------------------------ */ -cl_object -si_ihs_env(cl_object arg) +static void +frs_init(cl_env_ptr env) { - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, get_ihs_ptr(ecl_to_size(arg))->lex_env); + cl_index size, margin, limit_size; + margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; + limit_size = ecl_option_values[ECL_OPT_FRAME_STACK_SIZE]; + size = limit_size + 2 * margin; + env->frs_stack.org = (ecl_frame_ptr)ecl_malloc(size * sizeof(*env->frs_stack.org)); + env->frs_stack.top = env->frs_stack.org-1; + env->frs_stack.limit = &env->frs_stack.org[limit_size]; + env->frs_stack.size = size; + env->frs_stack.limit_size = limit_size; } -/* ------------------------- FRAME STACK ------------------------------ */ - -static void -frs_set_size(cl_env_ptr env, cl_index new_size) +void +ecl_frs_set_limit(cl_env_ptr env, cl_index new_lim_size) { - ecl_frame_ptr old_org = env->frs_org; - cl_index limit = env->frs_top - old_org; - if (new_size <= limit) { - FEerror("Cannot shrink frame stack below ~D.", 1, - ecl_make_unsigned_integer(limit)); - } else { - cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; - ecl_frame_ptr org; - env->frs_limit_size = new_size - 2*margin; - org = ecl_alloc_atomic(new_size * sizeof(*org)); - - ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); - memcpy(org, old_org, (limit + 1) * sizeof(*org)); - env->frs_top = org + limit; - env->frs_org = org; - env->frs_limit = org + (new_size - 2*margin); - env->frs_size = new_size; - ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); - - ecl_dealloc(old_org); - } + cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; + ecl_frame_ptr old_org = env->frs_stack.org; + ecl_frame_ptr new_org = NULL; + cl_index osize = env->frs_stack.size; + cl_index nsize = new_lim_size + 2*margin; + cl_index current_size = env->frs_stack.top - old_org; + if(current_size > new_lim_size) + ecl_internal_error("Cannot shrink frame stack below its minimal element"); + new_org = ecl_realloc(old_org, + osize * sizeof(*old_org), + nsize * sizeof(*old_org)); + ECL_STACK_RESIZE_DISABLE_INTERRUPTS(env); + env->frs_stack.org = new_org; + env->frs_stack.top = new_org + current_size; + env->frs_stack.limit = new_org + new_lim_size; + /* Update indexes. */ + env->frs_stack.size = nsize; + env->frs_stack.limit_size = new_lim_size; + ECL_STACK_RESIZE_ENABLE_INTERRUPTS(env); } static void -frs_overflow(void) /* used as condition in list.d */ +frs_overflow(void) { static const char *stack_overflow_msg = "\n;;;\n;;; Frame stack overflow.\n" @@ -672,17 +606,15 @@ frs_overflow(void) /* used as condition in list.d */ ";;;\n\n"; cl_env_ptr env = ecl_process_env(); cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; - cl_index size = env->frs_size; - ecl_frame_ptr org = env->frs_org; + cl_index size = env->frs_stack.size; + cl_index limit_size = env->frs_stack.limit_size; + ecl_frame_ptr org = env->frs_stack.org; ecl_frame_ptr last = org + size; - if (env->frs_limit >= last) { - ecl_unrecoverable_error(env, stack_overflow_msg); + if (env->frs_stack.limit >= last) { + ecl_internal_error(stack_overflow_msg); } - env->frs_limit += margin; - si_serror(6, @"Extend stack size", - @'ext::stack-overflow', @':size', ecl_make_fixnum(size), - @':type', @'ext::frame-stack'); - frs_set_size(env, size + size / 2); + env->frs_stack.limit += margin; + ecl_cerror(ECL_EX_FRS_OVR, ecl_make_fixnum(limit_size), ECL_T); } ecl_frame_ptr @@ -693,199 +625,189 @@ _ecl_frs_push(cl_env_ptr env) * stray ECL_PROTECT_TAG will lead to segfaults. AO_nop_full is * needed to ensure that the CPU doesn't reorder the memory * stores. */ - ecl_frame_ptr output = env->frs_top+1; - if (output >= env->frs_limit) { + ecl_frame_ptr output = env->frs_stack.top+1; + if (output >= env->frs_stack.limit) { frs_overflow(); - output = env->frs_top+1; + output = env->frs_stack.top+1; } output->frs_val = ECL_DUMMY_TAG; AO_nop_full(); - ++env->frs_top; - output->frs_bds_top_index = env->bds_top - env->bds_org; - output->frs_ihs = env->ihs_top; - output->frs_sp = ECL_STACK_INDEX(env); + ++env->frs_stack.top; + output->frs_bds_ndx = env->bds_stack.top - env->bds_stack.org; + output->frs_vms_ndx = ecl_vms_index(env); + output->frs_ihs = env->ihs_stack.top; return output; } -void -ecl_unwind(cl_env_ptr env, ecl_frame_ptr fr) -{ - env->nlj_fr = fr; - ecl_frame_ptr top = env->frs_top; - while (top != fr && top->frs_val != ECL_PROTECT_TAG){ - top->frs_val = ECL_DUMMY_TAG; - --top; - } - env->ihs_top = top->frs_ihs; - ecl_bds_unwind(env, top->frs_bds_top_index); - ECL_STACK_SET_INDEX(env, top->frs_sp); - env->frs_top = top; - ecl_longjmp(env->frs_top->frs_jmpbuf, 1); - /* never reached */ -} - ecl_frame_ptr frs_sch (cl_object frame_id) { cl_env_ptr env = ecl_process_env(); ecl_frame_ptr top; - for (top = env->frs_top; top >= env->frs_org; top--) + for (top = env->frs_stack.top; top >= env->frs_stack.org; top--) if (top->frs_val == frame_id) return(top); return(NULL); } -static ecl_frame_ptr -get_frame_ptr(cl_object x) +/* -- Module definition ------------------------------------------------------ */ + +static cl_object +create_stacks() { - if (ECL_FIXNUMP(x)) { - cl_env_ptr env = ecl_process_env(); - ecl_frame_ptr p = env->frs_org + ecl_fixnum(x); - if (env->frs_org <= p && p <= env->frs_top) - return p; + cl_env_ptr the_env = ecl_core.first_env; +#ifdef ECL_THREADS + cl_index idx; + cl_object *vector = (cl_object *)ecl_malloc(1024*sizeof(cl_object*)); + for(idx=0; idx<1024; idx++) { + vector[idx] = ECL_NO_TL_BINDING; } - FEerror("~S is an illegal frs index.", 1, x); + the_env->bds_stack.tl_bindings_size = 1024; + the_env->bds_stack.tl_bindings = vector; +#endif + the_env->c_stack.org = NULL; + return ECL_NIL; } -cl_object -si_frs_top() +static cl_object +enable_stacks() { - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(env->frs_top - env->frs_org)); + return ECL_NIL; } -cl_object -si_frs_bds(cl_object arg) +static cl_object +init_env_stacks(cl_env_ptr the_env) { - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_bds_top_index)); + frs_init(the_env); + bds_init(the_env); + run_init(the_env); + ihs_init(the_env); + the_env->c_stack.org = NULL; + return ECL_NIL; } -cl_object -si_frs_tag(cl_object arg) +static cl_object +init_cpu_stacks(cl_env_ptr the_env) { - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, get_frame_ptr(arg)->frs_val); + ecl_cs_init(the_env); + return ECL_NIL; } -cl_object -si_frs_ihs(cl_object arg) +static cl_object +free_cpu_stacks(cl_env_ptr the_env) { - cl_env_ptr env = ecl_process_env(); - ecl_return1(env, ecl_make_fixnum(get_frame_ptr(arg)->frs_ihs->index)); + return ECL_NIL; } -cl_object -si_sch_frs_base(cl_object fr, cl_object ihs) +static cl_object +free_env_stacks(cl_env_ptr the_env) { - cl_env_ptr env = ecl_process_env(); - ecl_frame_ptr x; - cl_index y = ecl_to_size(ihs); - for (x = get_frame_ptr(fr); - x <= env->frs_top && x->frs_ihs->index < y; - x++); - ecl_return1(env, ((x > env->frs_top) ? ECL_NIL : ecl_make_fixnum(x - env->frs_org))); +#ifdef ECL_THREADS + ecl_free(the_env->bds_stack.tl_bindings); + the_env->bds_stack.tl_bindings_size = 0; +#endif + ecl_free(the_env->run_stack.org); + ecl_free(the_env->bds_stack.org); + ecl_free(the_env->frs_stack.org); + return ECL_NIL; } -/* ------------------------- INITIALIZATION --------------------------- */ +ecl_def_ct_base_string(str_stacks, "STACKS", 6, static, const); +static struct ecl_module module_stacks = { + .name = str_stacks, + .create = create_stacks, + .enable = enable_stacks, + .init_env = init_env_stacks, + .init_cpu = init_cpu_stacks, + .free_cpu = free_cpu_stacks, + .free_env = free_env_stacks, + .disable = ecl_module_no_op, + .destroy = ecl_module_no_op +}; + +cl_object ecl_module_stacks = (cl_object)&module_stacks; + +/* -- General purpose stack implementation ----------------------------------- */ + +/* Stacks are based on actually adjustable simple vectors. */ cl_object -si_set_limit(cl_object type, cl_object limit) +ecl_make_stack(cl_index size) +{ + cl_object x = ecl_malloc(sizeof(struct ecl_vector)); + x->vector.elttype = ecl_aet_object; + x->vector.self.t = NULL; + x->vector.displaced = ECL_NIL; + x->vector.dim = size; + x->vector.fillp = 0; + x->vector.flags = ECL_FLAG_ADJUSTABLE | ECL_FLAG_HAS_FILL_POINTER; + x->vector.self.t = (cl_object *)ecl_malloc(size * sizeof(cl_object)); + return x; +} +void +ecl_free_stack(cl_object self) { - cl_env_ptr env = ecl_process_env(); - cl_index margin; - if (type == @'ext::frame-stack') { - cl_index the_size = ecl_to_size(limit); - margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; - frs_set_size(env, the_size + 2*margin); - } else if (type == @'ext::binding-stack') { - cl_index the_size = ecl_to_size(limit); - margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - ecl_bds_set_size(env, the_size + 2*margin); - } else if (type == @'ext::c-stack') { - cl_index the_size = ecl_to_size(limit); - margin = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA]; - cs_set_size(env, the_size + 2*margin); - } else if (type == @'ext::lisp-stack') { - cl_index the_size = ecl_to_size(limit); - ecl_stack_set_size(env, the_size); - } else if (type == @'ext::heap-size') { - /* - * size_t can be larger than cl_index, and ecl_to_size() - * creates a fixnum which is too small for size_t on 32-bit. - */ - size_t the_size = (size_t)ecl_to_ulong(limit); - _ecl_set_max_heap_size(the_size); - } + ecl_free(self->vector.self.t); +} - ecl_return1(env, si_get_limit(type)); +void +ecl_stack_resize(cl_object self, cl_index nsize) +{ + cl_index osize = self->vector.dim; + self->vector.self.t = (cl_object *)ecl_realloc(self->vector.self.t, + osize * sizeof(cl_object), + nsize * sizeof(cl_object)); + self->vector.dim = nsize; } -cl_object -si_get_limit(cl_object type) +void +stack_ensure_size(cl_object self, cl_index nsize) { - cl_env_ptr env = ecl_process_env(); - cl_index output = 0; - if (type == @'ext::frame-stack') - output = env->frs_limit_size; - else if (type == @'ext::binding-stack') - output = env->bds_limit_size; - else if (type == @'ext::c-stack') - output = env->cs_limit_size; - else if (type == @'ext::lisp-stack') - output = env->stack_limit_size; - else if (type == @'ext::heap-size') { - /* size_t can be larger than cl_index */ - ecl_return1(env, ecl_make_unsigned_integer(cl_core.max_heap_size)); + if (nsize >= self->vector.dim) { + ecl_stack_resize(self, nsize); } +} - ecl_return1(env, ecl_make_unsigned_integer(output)); +cl_index +ecl_stack_index(cl_object self) { + return self->vector.fillp; } cl_object -si_reset_margin(cl_object type) +ecl_stack_push(cl_object self, cl_object elt) { - cl_env_ptr env = ecl_process_env(); - if (type == @'ext::frame-stack') - frs_set_size(env, env->frs_size); - else if (type == @'ext::binding-stack') - ecl_bds_set_size(env, env->bds_size); - else if (type == @'ext::c-stack') - cs_set_size(env, env->cs_size); - else - ecl_return1(env, ECL_NIL); + cl_index fillp = self->vector.fillp; + cl_index dim = self->vector.dim; + if (ecl_unlikely(fillp == dim)) { + cl_index new_dim = dim+dim/2+1; + ecl_stack_resize(self, new_dim); + } + self->vector.self.t[self->vector.fillp++] = elt; + return self; +} - ecl_return1(env, ECL_T); +cl_object +ecl_stack_del(cl_object self, cl_object elt) +{ + cl_index idx; + cl_index ndx = self->vector.fillp; + cl_object *v = self->vector.self.t; + for(idx = 0; idx < ndx; idx++) { + if (v[idx] == elt) { + do { v[idx] = v[idx+1]; } while (++idx <= ndx); + ecl_stack_popu(self); + break; + } + } + return self; } -void -init_stacks(cl_env_ptr env) +/* Unsafe operations */ + +cl_object +ecl_stack_popu(cl_object self) { - static struct ecl_ihs_frame ihs_org = { NULL, NULL, NULL, 0}; - cl_index size, margin; - /* frame stack */ - margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA]; - size = ecl_option_values[ECL_OPT_FRAME_STACK_SIZE] + 2 * margin; - env->frs_size = size; - env->frs_org = (ecl_frame_ptr)ecl_alloc_atomic(size * sizeof(*env->frs_org)); - env->frs_top = env->frs_org-1; - env->frs_limit = &env->frs_org[size - 2*margin]; - /* bind stack */ - margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA]; - size = ecl_option_values[ECL_OPT_BIND_STACK_SIZE] + 2 * margin; - env->bds_size = size; - env->bds_org = (ecl_bds_ptr)ecl_alloc_atomic(size * sizeof(*env->bds_org)); - env->bds_top = env->bds_org-1; - env->bds_limit = &env->bds_org[size - 2*margin]; - /* ihs stack */ - env->ihs_top = &ihs_org; - ihs_org.function = ECL_NIL; - ihs_org.lex_env = ECL_NIL; - ihs_org.index = 0; - /* lisp stack */ - env->stack = NULL; - env->stack_top = NULL; - env->stack_limit = NULL; - env->stack_size = 0; - ecl_stack_set_size(env, ecl_option_values[ECL_OPT_LISP_STACK_SIZE]); + cl_object result = self->vector.self.t[--self->vector.fillp]; + self->vector.self.t[self->vector.fillp] = ECL_NIL; + return result; } diff --git a/src/c/string.d b/src/c/string.d index 32093f8b89fcfad2d28262fd20774d1950445ee1..7058dbfa48ab06f57c3237a0848cbb12b91aa1e4 100644 --- a/src/c/string.d +++ b/src/c/string.d @@ -881,14 +881,14 @@ nstring_case(cl_narg narg, cl_object fun, ecl_casefun casefun, ecl_va_list ARGS) for (i = 0, l = 0; i < narg; i++) { cl_object s = si_coerce_to_base_string(ecl_va_arg(args)); if (s->base_string.fillp) { - ECL_STACK_PUSH(the_env, s); + ecl_vms_push(the_env, s); l += s->base_string.fillp; } } /* Do actual copying by recovering those strings */ output = ecl_alloc_simple_base_string(l); while (l) { - cl_object s = ECL_STACK_POP_UNSAFE(the_env); + cl_object s = ecl_vms_popu(the_env); size_t bytes = s->base_string.fillp; l -= bytes; memcpy(output->base_string.self + l, s->base_string.self, bytes); diff --git a/src/c/symbol.d b/src/c/symbol.d index a89faaea94104bbc7c4872ff079baca606064d28..fe4945da17decf194b279c03d910f9db7c96d547 100644 --- a/src/c/symbol.d +++ b/src/c/symbol.d @@ -159,7 +159,7 @@ ecl_cmp_symbol_value(cl_env_ptr the_env, cl_object s) #ifndef ECL_FINAL /* Symbols are not initialized yet. This test is issued only during ECL compilation to ensure, that we have no early references in the core. */ - if(cl_num_symbols_in_core < 3) { + if(cl_num_symbols_in_core < 2) { ecl_internal_error("SYMBOL-VALUE: symbols are not initialized yet."); } #endif diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index f5da4b0720cb83607fe27e6ad014a089acc3e777..0d4d063e78aaf3a7409463a5af7000ab10371221 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -102,13 +102,11 @@ cl_symbol_initializer cl_symbols[] = { {"NIL" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)}, -{"T" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)}, -{SYS_ "UNBOUND" ECL_FUN("si_unbound", si_unbound, 0) ECL_VAR(SI_CONSTANT, ECL_UNBOUND)}, -{SYS_ "PROTECT-TAG" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, -{SYS_ "DUMMY-TAG" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, -{SYS_ "*RESTART-CLUSTERS*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)}, -{SYS_ "*HANDLER-CLUSTERS*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)}, -{EXT_ "*INTERRUPTS-ENABLED*" ECL_FUN(NULL, NULL, 1) ECL_VAR(EXT_SPECIAL, ECL_T)}, + +{SYS_ "%ESCAPE" ECL_FUN("ecl_escape", ecl_escape, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "%SIGNAL" ECL_FUN("ecl_signal", ecl_signal, 3) ECL_VAR(SI_ORDINARY, OBJNULL)}, + +{SYS_ "EXCEPTION-HANDLER" ECL_FUN("ecl_exception_handler", ecl_exception_handler, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, /* LISP PACKAGE */ {"&ALLOW-OTHER-KEYS" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)}, @@ -1270,7 +1268,6 @@ cl_symbols[] = { {EXT_ "SAFE-EVAL" ECL_FUN("si_safe_eval", ECL_NAME(si_safe_eval), -3) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {SYS_ "SCH-FRS-BASE" ECL_FUN("si_sch_frs_base", si_sch_frs_base, 2) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "SCHAR-SET" ECL_FUN("si_char_set", si_char_set, 3) ECL_VAR(SI_ORDINARY, OBJNULL)}, -{SYS_ "SERROR" ECL_FUN("si_serror", si_serror, -3) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "SHARP-A-READER" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "SHARP-S-READER" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "SELECT-PACKAGE" ECL_FUN("si_select_package", si_select_package, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, @@ -1304,7 +1301,6 @@ cl_symbols[] = { {SYS_ "TERMINAL-INTERRUPT" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "TOP-LEVEL" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "UNIVERSAL-ERROR-HANDLER" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, -{SYS_ "STACK-ERROR-HANDLER" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "VALID-FUNCTION-NAME-P" ECL_FUN("si_valid_function_name_p", si_valid_function_name_p, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "SEARCH-PRINT-CIRCLE" ECL_FUN("si_search_print_circle", si_search_print_circle, 1) ECL_VAR(SI_SPECIAL, OBJNULL)}, {SYS_ "WRITE-OBJECT-WITH-CIRCLE" ECL_FUN("si_write_object_with_circle", si_write_object_with_circle, 3) ECL_VAR(SI_SPECIAL, OBJNULL)}, @@ -1355,7 +1351,6 @@ cl_symbols[] = { {KEY_ "ADJUSTABLE" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "ABORT" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "ABSOLUTE" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, -{KEY_ "ALLOW-OTHER-KEYS" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "APPEND" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "ARRAY" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, {KEY_ "BACK" ECL_FUN(NULL, NULL, -1) ECL_VAR(KEYWORD, OBJNULL)}, @@ -1845,6 +1840,8 @@ cl_symbols[] = { {SYS_ "CODE-BLOCK" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "EXCEPTION" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "MODULE" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "FRAME" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "APPLY-FROM-STACK-FRAME" ECL_FUN("si_apply_from_stack_frame", si_apply_from_stack_frame, 2) ECL_VAR(SI_ORDINARY, OBJNULL)}, @@ -1922,7 +1919,6 @@ cl_symbols[] = { {EXT_ "ILLEGAL-INSTRUCTION" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {EXT_ "SET-LIMIT" ECL_FUN("si_set_limit", si_set_limit, 2) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {EXT_ "GET-LIMIT" ECL_FUN("si_get_limit", si_get_limit, 1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, -{SYS_ "RESET-MARGIN" ECL_FUN("si_reset_margin", si_reset_margin, 1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {EXT_ "SEGMENTATION-VIOLATION" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, {EXT_ "EXTENDED-STRING" ECL_FUN(NULL, NULL, -1) ECL_VAR(EXT_ORDINARY, OBJNULL)}, diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index ad06830ba3b5f80566dd1ba7ac9d0c24fad85c31..ecf7dc72b042fb0676b1924e56be93e2c147401f 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -31,111 +31,25 @@ # include #endif -/* -- Macros -------------------------------------------------------- */ - -#ifdef ECL_WINDOWS_THREADS -# define ecl_process_eq(t1, t2) (GetThreadId(t1) == GetThreadId(t2)) -# define ecl_set_process_self(var) \ - { \ - HANDLE aux = GetCurrentThread(); \ - DuplicateHandle(GetCurrentProcess(), \ - aux, \ - GetCurrentProcess(), \ - &var, \ - 0, \ - FALSE, \ - DUPLICATE_SAME_ACCESS); \ - } -#else -# define ecl_process_eq(t1, t2) (t1 == t2) -# define ecl_set_process_self(var) (var = pthread_self()) -#endif /* ECL_WINDOWS_THREADS */ - /* -- Core ---------------------------------------------------------- */ -static void -extend_process_vector() -{ - cl_object v = cl_core.processes; - cl_index new_size = v->vector.dim + v->vector.dim/2; - cl_env_ptr the_env = ecl_process_env(); - ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &cl_core.processes_lock) { - cl_object other = cl_core.processes; - if (new_size > other->vector.dim) { - cl_object new = si_make_vector(ECL_T, - ecl_make_fixnum(new_size), - ecl_make_fixnum(other->vector.fillp), - ECL_NIL, ECL_NIL, ECL_NIL); - ecl_copy_subarray(new, 0, other, 0, other->vector.dim); - cl_core.processes = new; - } - } ECL_WITH_NATIVE_LOCK_END; -} - -static void -ecl_list_process(cl_object process) -{ - cl_env_ptr the_env = ecl_process_env(); - bool ok = 0; - do { - ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &cl_core.processes_lock) { - cl_object vector = cl_core.processes; - cl_index size = vector->vector.dim; - cl_index ndx = vector->vector.fillp; - if (ndx < size) { - vector->vector.self.t[ndx++] = process; - vector->vector.fillp = ndx; - ok = 1; - } - } ECL_WITH_NATIVE_LOCK_END; - if (ok) break; - extend_process_vector(); - } while (1); -} - -/* Must be called with disabled interrupts to prevent race conditions - * in thread_cleanup */ -static void -ecl_unlist_process(cl_object process) -{ - ecl_mutex_lock(&cl_core.processes_lock); - cl_object vector = cl_core.processes; - cl_index i; - for (i = 0; i < vector->vector.fillp; i++) { - if (vector->vector.self.t[i] == process) { - vector->vector.fillp--; - do { - vector->vector.self.t[i] = - vector->vector.self.t[i+1]; - } while (++i < vector->vector.fillp); - break; - } - } - ecl_mutex_unlock(&cl_core.processes_lock); -} - static cl_object ecl_process_list() { cl_env_ptr the_env = ecl_process_env(); cl_object output = ECL_NIL; - ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &cl_core.processes_lock) { - cl_object vector = cl_core.processes; - cl_object *data = vector->vector.self.t; - cl_index i; - for (i = 0; i < vector->vector.fillp; i++) { - cl_object p = data[i]; - if (p != ECL_NIL) - output = ecl_cons(p, output); - } + ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &ecl_core.processes_lock) { + loop_across_stack_fifo(_env, ecl_core.threads) { + cl_env_ptr env = ecl_cast_ptr(cl_env_ptr, _env); + cl_object p = env->own_process; + output = ecl_cons(p, output); + } end_loop_across_stack(); } ECL_WITH_NATIVE_LOCK_END; return output; } /* -- Environment --------------------------------------------------- */ -extern void ecl_init_env(struct cl_env_struct *env); - cl_object mp_current_process(void) { @@ -151,149 +65,94 @@ assert_type_process(cl_object o) FEwrong_type_argument(@[mp::process], o); } -static void -thread_cleanup(void *aux) -{ - /* This routine performs some cleanup before a thread is completely - * killed. For instance, it has to remove the associated process - * object from the list, an it has to dealloc some memory. - * - * NOTE: thread_cleanup() does not provide enough "protection". In - * order to ensure that all UNWIND-PROTECT forms are properly - * executed, never use pthread_cancel() to kill a process, but - * rather use the lisp functions mp_interrupt_process() and - * mp_process_kill(). - */ - cl_object process = (cl_object)aux; - cl_env_ptr env = process->process.env; - - /* The following flags will disable all interrupts. */ - if (env) { - ecl_disable_interrupts_env(env); - ecl_clear_bignum_registers(env); - } - ecl_mutex_lock(&process->process.start_stop_lock); - process->process.phase = ECL_PROCESS_EXITING; -#ifdef HAVE_SIGPROCMASK - /* ...but we might get stray signals. */ - { - sigset_t new[1]; - sigemptyset(new); - sigaddset(new, ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]); - pthread_sigmask(SIG_BLOCK, new, NULL); - } -#endif - process->process.env = NULL; - ecl_unlist_process(process); -#ifdef ECL_WINDOWS_THREADS - CloseHandle(process->process.thread); -#endif - ecl_set_process_env(NULL); - if (env) _ecl_dealloc_env(env); - - process->process.phase = ECL_PROCESS_INACTIVE; - ecl_cond_var_broadcast(&process->process.exit_barrier); - ecl_mutex_unlock(&process->process.start_stop_lock); -} - -#ifdef ECL_WINDOWS_THREADS -static DWORD WINAPI -#else -static void * -#endif -thread_entry_point(void *arg) +static cl_object +run_process(cl_narg narg, ...) { - cl_object process = (cl_object)arg; - cl_env_ptr env = process->process.env; - - /* - * Upon entering this routine - * process.env = our environment for lisp - * process.phase = ECL_PROCESS_BOOTING - * signals are disabled in the environment - * the communication interrupt is disabled (sigmasked) + /* Upon entering this routine the process environment is set up, the process + * phase is ECL_PROCESS_BOOTING, signals are disabled in the environment and + * the communication interrupt is disabled (sigmasked). * - * This process will not receive signals that originate from - * other processes. Furthermore, we expect not to get any - * other interrupts (SIGSEGV, SIGFPE) if we do things right. + * This process will not receive signals that originate from other processes. + * Furthermore, we expect not to get any other interrupts (SIGSEGV, SIGFPE) if + * we do things right. */ - /* 1) Setup the environment for the execution of the thread */ - ecl_set_process_env(env = process->process.env); -#ifndef ECL_WINDOWS_THREADS - pthread_cleanup_push(thread_cleanup, (void *)process); -#endif - ecl_cs_set_org(env); + cl_env_ptr the_env = ecl_process_env(); + cl_object process = the_env->own_process; + cl_object fun = process->process.function; + cl_object args = process->process.args; + cl_object output = ECL_NIL; + /* Entry barrier. enable_process releases this lock before exit. */ ecl_mutex_lock(&process->process.start_stop_lock); - /* 2) Execute the code. The CATCH_ALL point is the destination - * provides us with an elegant way to exit the thread: we just - * do an unwind up to frs_top. - */ - ECL_CATCH_ALL_BEGIN(env) { + /* Execute the code. The CATCH_ALL point is the destination provides us with + * an elegant way to exit the thread: we just do an unwind up to frs_top. */ + ECL_CATCH_ALL_BEGIN(the_env) { #ifdef HAVE_SIGPROCMASK { - sigset_t *new = (sigset_t*)env->default_sigmask; - pthread_sigmask(SIG_SETMASK, new, NULL); + sigset_t *new = (sigset_t*)the_env->default_sigmask; + ecl_sigmask(SIG_SETMASK, new, NULL); } #endif process->process.phase = ECL_PROCESS_ACTIVE; ecl_mutex_unlock(&process->process.start_stop_lock); - ecl_enable_interrupts_env(env); si_trap_fpe(@'last', ECL_T); - ecl_bds_bind(env, @'mp::*current-process*', process); - - ECL_RESTART_CASE_BEGIN(env, @'abort') { - env->values[0] = cl_apply(2, process->process.function, - process->process.args); - { - cl_object output = ECL_NIL; - int i = env->nvalues; - while (i--) { - output = CONS(env->values[i], output); - } - process->process.exit_values = output; + + ecl_enable_interrupts_env(the_env); + ecl_bds_bind(the_env, @'mp::*current-process*', process); + + ECL_RESTART_CASE_BEGIN(the_env, @'abort') { + the_env->values[0] = cl_apply(2, fun, args); + int i = the_env->nvalues; + while (i--) { + output = CONS(the_env->values[i], output); } + process->process.exit_values = output; } ECL_RESTART_CASE(1,args) { /* ABORT restart. */ process->process.exit_values = args; } ECL_RESTART_CASE_END; - ecl_bds_unwind1(env); + /* This routine performs some cleanup before a thread is finished. Note that + it does not provide enough protection -- in order to ensure that all + UNWIND-PROTECT forms are properly executed, enver use the function + pthread_cancel() to kill a process, but rather use the lisp functions + mp_interrupt_process() and mp_process_kill(). */ + ecl_bds_unwind1(the_env); } ECL_CATCH_ALL_END; - /* 4) If everything went right, we should be exiting the thread - * through this point. thread_cleanup is automatically invoked - * marking the process as inactive. - */ -#ifdef ECL_WINDOWS_THREADS - thread_cleanup(process); - return 1; -#else - pthread_cleanup_pop(1); - return NULL; + ecl_disable_interrupts_env(the_env); + + ecl_mutex_lock(&process->process.start_stop_lock); + process->process.phase = ECL_PROCESS_EXITING; +#ifdef HAVE_SIGPROCMASK + /* ...but we might get stray signals. */ + { + sigset_t new[1]; + sigemptyset(new); + sigaddset(new, ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]); + ecl_sigmask(SIG_BLOCK, new, NULL); + } #endif + process->process.env = NULL; + process->process.phase = ECL_PROCESS_INACTIVE; + ecl_cond_var_broadcast(&process->process.exit_barrier); + ecl_mutex_unlock(&process->process.start_stop_lock); + + return the_env->values[0]; } static cl_object -alloc_process(cl_object name, cl_object initial_bindings) +alloc_process(cl_object name, cl_object initial_bindings_p) { cl_env_ptr env = ecl_process_env(); - cl_object process = ecl_alloc_object(t_process), array; + cl_object process = ecl_alloc_object(t_process); process->process.phase = ECL_PROCESS_INACTIVE; + process->process.exit_values = ECL_NIL; + process->process.entry = run_process; process->process.name = name; process->process.function = ECL_NIL; process->process.args = ECL_NIL; - process->process.interrupt = ECL_NIL; - process->process.exit_values = ECL_NIL; - process->process.env = NULL; - if (initial_bindings != ECL_NIL || env->bindings_array == OBJNULL) { - array = si_make_vector(ECL_T, ecl_make_fixnum(256), - ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL); - si_fill_array_with_elt(array, ECL_NO_TL_BINDING, ecl_make_fixnum(0), ECL_NIL); - } else { - array = cl_copy_seq(ecl_process_env()->bindings_array); - } - process->process.initial_bindings = array; process->process.woken_up = ECL_NIL; + process->process.inherit_bindings_p = Null(initial_bindings_p)? ECL_T : ECL_NIL; ecl_disable_interrupts_env(env); ecl_mutex_init(&process->process.start_stop_lock, TRUE); ecl_cond_var_init(&process->process.exit_barrier); @@ -305,95 +164,55 @@ alloc_process(cl_object name, cl_object initial_bindings) bool ecl_import_current_thread(cl_object name, cl_object bindings) { - struct cl_env_struct env_aux[1]; cl_object process; - ecl_thread_t current; - cl_env_ptr env; - int registered; - struct GC_stack_base stack; - ecl_set_process_self(current); -#ifdef GBC_BOEHM - GC_get_stack_base(&stack); - switch (GC_register_my_thread(&stack)) { - case GC_SUCCESS: - registered = 1; - break; - case GC_DUPLICATE: - /* Thread was probably created using the GC hooks for thread creation. */ - registered = 0; - break; - default: + cl_env_ptr the_env; + if (ecl_process_env_unsafe() != NULL) return 0; - } -#endif - { - cl_object processes = cl_core.processes; - cl_index i, size; - for (i = 0, size = processes->vector.fillp; i < size; i++) { - cl_object p = processes->vector.self.t[i]; - if (!Null(p) && ecl_process_eq(p->process.thread, current)) { - return 0; - } - } - } - /* We need a fake env to allow for interrupts blocking and to set up - * frame stacks or other stuff which may be needed by alloc_process - * and ecl_list_process. Since the fake env is allocated on the stack, - * we can safely store pointers to memory allocated by the gc there. */ - memset(env_aux, 0, sizeof(*env_aux)); - env_aux->disable_interrupts = 1; - env_aux->interrupt_struct = ecl_alloc_unprotected(sizeof(*env_aux->interrupt_struct)); - env_aux->interrupt_struct->pending_interrupt = ECL_NIL; - ecl_mutex_init(&env_aux->interrupt_struct->signal_queue_lock, FALSE); - env_aux->interrupt_struct->signal_queue = ECL_NIL; - ecl_set_process_env(env_aux); - ecl_init_env(env_aux); - - /* Allocate real environment, link it together with process */ - env = _ecl_alloc_env(0); - process = alloc_process(name, bindings); - process->process.env = env; - process->process.phase = ECL_PROCESS_BOOTING; - process->process.thread = current; - - /* Copy initial bindings from process to the fake environment */ - env_aux->cleanup = registered; - env_aux->bindings_array = process->process.initial_bindings; - env_aux->thread_local_bindings_size = env_aux->bindings_array->vector.dim; - env_aux->thread_local_bindings = env_aux->bindings_array->vector.self.t; - - /* Switch over to the real environment */ - memcpy(env, env_aux, sizeof(*env)); - env->own_process = process; - ecl_set_process_env(env); - ecl_list_process(process); - ecl_enable_interrupts_env(env); + ecl_module_gc->module.disable(); + the_env = ecl_adopt_cpu(); + ecl_module_gc->module.enable(); + ecl_enable_interrupts_env(the_env); + process = alloc_process(name, ECL_NIL); + process->process.env = the_env; + process->process.phase = ECL_PROCESS_BOOTING; + the_env->own_process = process; process->process.phase = ECL_PROCESS_ACTIVE; - ecl_bds_bind(env, @'mp::*current-process*', process); + ecl_bds_bind(the_env, @'mp::*current-process*', process); return 1; } void ecl_release_current_thread(void) { - cl_env_ptr env = ecl_process_env(); - - int cleanup = env->cleanup; - cl_object own_process = env->own_process; - thread_cleanup(own_process); -#ifdef GBC_BOEHM - if (cleanup) { - GC_unregister_my_thread(); + cl_object process; + cl_env_ptr the_env = ecl_process_env_unsafe(); + if (the_env == NULL) + return; + process = the_env->own_process; + ecl_mutex_lock(&process->process.start_stop_lock); + process->process.env = NULL; + process->process.phase = ECL_PROCESS_EXITING; + ecl_disown_cpu(); +#ifdef HAVE_SIGPROCMASK + /* ...but we might get stray signals. */ + { + sigset_t new[1]; + sigemptyset(new); + sigaddset(new, ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]); + ecl_sigmask(SIG_BLOCK, new, NULL); } #endif + process->process.phase = ECL_PROCESS_INACTIVE; + ecl_cond_var_broadcast(&process->process.exit_barrier); + ecl_mutex_unlock(&process->process.start_stop_lock); } -@(defun mp::make-process (&key name ((:initial-bindings initial_bindings) ECL_T)) +@(defun mp::make-process (&key name ((:initial-bindings initial_bindings_p) ECL_T)) cl_object process; @ - process = alloc_process(name, initial_bindings); + process = alloc_process(name, initial_bindings_p); @(return process); @) @@ -480,115 +299,35 @@ mp_process_yield(void) cl_object mp_process_enable(cl_object process) { - /* process_env and ok are changed after the setjmp call in - * ECL_UNWIND_PROTECT_BEGIN, so they need to be declared volatile */ - volatile cl_env_ptr process_env = NULL; cl_env_ptr the_env = ecl_process_env(); - volatile int ok = 1; - ECL_UNWIND_PROTECT_BEGIN(the_env) { - /* Try to gain exclusive access to the process. This prevents two - * concurrent calls to process-enable from different threads on - * the same process */ - ecl_mutex_lock(&process->process.start_stop_lock); - /* Ensure that the process is inactive. */ - if (process->process.phase != ECL_PROCESS_INACTIVE) { - FEerror("Cannot enable the running process ~A.", 1, process); - } - ok = 0; - process->process.phase = ECL_PROCESS_BOOTING; - - process->process.parent = mp_current_process(); - process->process.trap_fpe_bits = - process->process.parent->process.env->trap_fpe_bits; - - /* Link environment and process together */ - process_env = _ecl_alloc_env(the_env); - process_env->own_process = process; - process->process.env = process_env; - - /* Immediately list the process such that its environment is - * marked by the gc when its contents are allocated */ - ecl_list_process(process); - - /* Now we can safely allocate memory for the environment contents - * and store pointers to it in the environment */ - ecl_init_env(process_env); - - process_env->trap_fpe_bits = process->process.trap_fpe_bits; - process_env->bindings_array = process->process.initial_bindings; - process_env->thread_local_bindings_size = - process_env->bindings_array->vector.dim; - process_env->thread_local_bindings = - process_env->bindings_array->vector.self.t; - - ecl_disable_interrupts_env(the_env); -#ifdef ECL_WINDOWS_THREADS - { - HANDLE code; - DWORD threadId; - - code = (HANDLE)CreateThread(NULL, 0, thread_entry_point, process, 0, &threadId); - ok = (process->process.thread = code) != NULL; - } -#else - { - int code; - pthread_attr_t pthreadattr; - - pthread_attr_init(&pthreadattr); - pthread_attr_setdetachstate(&pthreadattr, PTHREAD_CREATE_DETACHED); - /* - * Block all asynchronous signals until the thread is completely - * set up. The synchronous signals SIGSEGV and SIGBUS are needed - * by the gc and thus can't be blocked. - */ -#ifdef HAVE_SIGPROCMASK - { - sigset_t new, previous; - sigfillset(&new); - sigdelset(&new, SIGSEGV); - sigdelset(&new, SIGBUS); - pthread_sigmask(SIG_BLOCK, &new, &previous); - code = pthread_create(&process->process.thread, &pthreadattr, - thread_entry_point, process); - pthread_sigmask(SIG_SETMASK, &previous, NULL); - } -#else - code = pthread_create(&process->process.thread, &pthreadattr, - thread_entry_point, process); -#endif - ok = (code == 0); - } -#endif - ecl_enable_interrupts_env(the_env); - } ECL_UNWIND_PROTECT_THREAD_SAFE_EXIT { - if (!ok) { - /* INV: interrupts are already disabled through thread safe - * unwind-protect */ - ecl_unlist_process(process); - process->process.phase = ECL_PROCESS_INACTIVE; - /* Alert possible waiting processes. */ - ecl_cond_var_broadcast(&process->process.exit_barrier); - process->process.env = NULL; - if (process_env != NULL) - _ecl_dealloc_env(process_env); - } - /* Unleash the thread */ + cl_env_ptr process_env = NULL; + /* Try to gain exclusive access to the process. This prevents two concurrent + * calls to process-enable from different threads on the same process */ + ecl_mutex_lock(&process->process.start_stop_lock); + /* Ensure that the process is inactive. */ + if (process->process.phase != ECL_PROCESS_INACTIVE) { ecl_mutex_unlock(&process->process.start_stop_lock); - } ECL_UNWIND_PROTECT_THREAD_SAFE_END; - - @(return (ok? process : ECL_NIL)); + FEerror("Cannot enable the running process ~A.", 1, process); + } + process->process.phase = ECL_PROCESS_BOOTING; + /* Spawn the thread (allocates the environment)*/ + process_env = ecl_spawn_cpu(process); + if (process_env == NULL) { + process->process.phase = ECL_PROCESS_INACTIVE; + ecl_cond_var_broadcast(&process->process.exit_barrier); + } + /* Unleash the thread */ + ecl_mutex_unlock(&process->process.start_stop_lock); + ecl_return1(the_env, (process_env ? process : ECL_NIL)); } cl_object mp_exit_process(void) { - /* We simply undo the whole of the frame stack. This brings up - back to the thread entry point, going through all possible - UNWIND-PROTECT. - */ + /* We simply undo the whole of the frame stack. This brings up back to the + thread entry point, going through all possible UNWIND-PROTECT. */ const cl_env_ptr the_env = ecl_process_env(); - ecl_unwind(the_env, the_env->frs_org); + ecl_unwind(the_env, the_env->frs_stack.org); /* Never reached */ } @@ -617,8 +356,9 @@ mp_process_active_p(cl_object process) cl_object mp_process_whostate(cl_object process) { + const cl_env_ptr the_env = ecl_process_env(); assert_type_process(process); - @(return (cl_core.null_string)); + ecl_return1(the_env, ecl_ct_null_string); } cl_object @@ -656,8 +396,7 @@ mp_process_run_function(cl_narg narg, cl_object name, cl_object function, ...) ecl_va_start(args, function, narg, 2); rest = cl_grab_rest_args(args); ecl_va_end(args); - cl_apply(4, @'mp::process-preset', process, function, - rest); + cl_apply(4, @'mp::process-preset', process, function, rest); return mp_process_enable(process); } @@ -690,8 +429,8 @@ mp_get_sigmask(void) sigset_t *mask_ptr = (sigset_t*)data->vector.self.b8; sigset_t no_signals; sigemptyset(&no_signals); - if (pthread_sigmask(SIG_BLOCK, &no_signals, mask_ptr)) - FElibc_error("MP:GET-SIGMASK failed in a call to pthread_sigmask", 0); + if (ecl_sigmask(SIG_BLOCK, &no_signals, mask_ptr)) + FElibc_error("MP:GET-SIGMASK failed in a call to ecl_sigmask", 0); @(return data); } @@ -699,8 +438,8 @@ static cl_object mp_set_sigmask(cl_object data) { sigset_t *mask_ptr = (sigset_t*)data->vector.self.b8; - if (pthread_sigmask(SIG_SETMASK, mask_ptr, NULL)) - FElibc_error("MP:SET-SIGMASK failed in a call to pthread_sigmask", 0); + if (ecl_sigmask(SIG_SETMASK, mask_ptr, NULL)) + FElibc_error("MP:SET-SIGMASK failed in a call to ecl_sigmask", 0); @(return data); } #endif @@ -710,8 +449,8 @@ mp_block_signals(void) { #ifdef ECL_WINDOWS_THREADS cl_env_ptr the_env = ecl_process_env(); - cl_object previous = ecl_cmp_symbol_value(the_env, @'ext::*interrupts-enabled*'); - ECL_SETQ(the_env, @'ext::*interrupts-enabled*', ECL_NIL); + cl_object previous = ecl_cmp_symbol_value(the_env, ECL_INTERRUPTS_ENABLED); + ECL_SETQ(the_env, ECL_INTERRUPTS_ENABLED, ECL_NIL); @(return previous); #else cl_object previous = mp_get_sigmask(); @@ -721,8 +460,8 @@ mp_block_signals(void) * can thus never be blocked */ sigdelset(&all_signals, SIGSEGV); sigdelset(&all_signals, SIGBUS); - if (pthread_sigmask(SIG_SETMASK, &all_signals, NULL)) - FElibc_error("MP:BLOCK-SIGNALS failed in a call to pthread_sigmask",0); + if (ecl_sigmask(SIG_SETMASK, &all_signals, NULL)) + FElibc_error("MP:BLOCK-SIGNALS failed in a call to ecl_sigmask",0); @(return previous); #endif } @@ -732,7 +471,7 @@ mp_restore_signals(cl_object sigmask) { #ifdef ECL_WINDOWS_THREADS cl_env_ptr the_env = ecl_process_env(); - ECL_SETQ(the_env, @'ext::*interrupts-enabled*', sigmask); + ECL_SETQ(the_env, ECL_INTERRUPTS_ENABLED, sigmask); ecl_check_pending_interrupts(the_env); @(return sigmask); #else @@ -740,36 +479,75 @@ mp_restore_signals(cl_object sigmask) #endif } -/* -- Initialization ------------------------------------------------ */ +/* -- Module definition --------------------------------------------- */ void init_threads() { - cl_env_ptr the_env = ecl_process_env(); - cl_object process; - ecl_thread_t main_thread; +} + +static cl_object +create_thread() +{ + cl_env_ptr the_env = ecl_core.first_env; + cl_object process, _env = ecl_cast_ptr(cl_object,the_env); /* We have to set the environment before any allocation takes place, * so that the interrupt handling code works. */ - ecl_set_process_self(main_thread); process = ecl_alloc_object(t_process); process->process.phase = ECL_PROCESS_ACTIVE; process->process.name = @'si::top-level'; process->process.function = ECL_NIL; process->process.args = ECL_NIL; - process->process.thread = main_thread; process->process.env = the_env; - process->process.woken_up = ECL_NIL; ecl_mutex_init(&process->process.start_stop_lock, TRUE); ecl_cond_var_init(&process->process.exit_barrier); - the_env->own_process = process; - { - cl_object v = si_make_vector(ECL_T, /* Element type */ - ecl_make_fixnum(256), /* Size */ - ecl_make_fixnum(0), /* fill pointer */ - ECL_NIL, ECL_NIL, ECL_NIL); - v->vector.self.t[0] = process; - v->vector.fillp = 1; - cl_core.processes = v; - } + ecl_stack_push(ecl_core.threads, _env); + return ECL_NIL; } + +static cl_object +enable_thread() +{ + return ECL_NIL; +} + +static cl_object +init_env_thread(cl_env_ptr the_env) +{ + return ECL_NIL; +} + +static cl_object +init_cpu_thread(cl_env_ptr the_env) +{ + return ECL_NIL; +} + +static cl_object +free_cpu_thread(cl_env_ptr the_env) +{ + return ECL_NIL; +} + +static cl_object +free_env_thread(cl_env_ptr the_env) +{ + return ECL_NIL; +} + +ecl_def_ct_base_string(str_thread, "THREAD", 6, static, const); + +static struct ecl_module module_thread = { + .name = str_thread, + .create = create_thread, + .enable = enable_thread, + .init_env = init_env_thread, + .init_cpu = init_cpu_thread, + .free_cpu = free_cpu_thread, + .free_env = free_env_thread, + .disable = ecl_module_no_op, + .destroy = ecl_module_no_op +}; + +cl_object ecl_module_thread = (cl_object)&module_thread; diff --git a/src/c/time.d b/src/c/time.d index 166a2a7c39a8697a3e6ba34361e6b2af5ea7c059..82ac93ae826c22faf0b595649c6165126db68df7 100644 --- a/src/c/time.d +++ b/src/c/time.d @@ -221,18 +221,14 @@ cl_get_internal_real_time() cl_object cl_get_universal_time() { + cl_env_ptr env = ecl_process_env(); cl_object utc = ecl_make_integer(time(0)); - @(return ecl_plus(utc, cl_core.Jan1st1970UT)); + ecl_return1(env, ecl_plus(utc, ecl_ct_Jan1st1970UT)); } void init_unixtime(void) { ecl_get_internal_real_time(&beginning); - ECL_SET(@'internal-time-units-per-second', ecl_make_fixnum(1000000)); - - cl_core.Jan1st1970UT = - ecl_times(ecl_make_fixnum(24 * 60 * 60), - ecl_make_fixnum(17 + 365 * 70)); } diff --git a/src/c/typespec.d b/src/c/typespec.d index 19e89538da9c1ac60e781ea365754da2a0d4ee63..5b53e230e875a9c946b2959bd02fcd22323ecf17 100644 --- a/src/c/typespec.d +++ b/src/c/typespec.d @@ -181,6 +181,10 @@ ecl_type_to_symbol(cl_type t) return @'si::foreign-data'; case t_frame: return @'si::frame'; + case t_exception: + return @'si::exception'; + case t_module: + return @'si::module'; case t_weak_pointer: return @'ext::weak-pointer'; #ifdef ECL_SSE2 diff --git a/src/c/unixfsys.d b/src/c/unixfsys.d index 56a6e48ea5dc8cea89bea3d6c214b1e77ef22fbc..a25b04868febf7aa98b4a26b93533965619168df 100644 --- a/src/c/unixfsys.d +++ b/src/c/unixfsys.d @@ -1085,7 +1085,7 @@ dir_recursive(cl_object base_dir, cl_object directory, cl_object filemask, int f cl_object si_get_library_pathname(void) { - cl_object s = cl_core.library_pathname; + cl_object s = ecl_core.library_pathname; if (!Null(s)) { goto OUTPUT_UNCHANGED; } else { @@ -1100,11 +1100,11 @@ si_get_library_pathname(void) ecl_filename_char *buffer; HMODULE hnd; cl_index len, ep; - s = ecl_alloc_adjustable_filename(cl_core.path_max); + s = ecl_alloc_adjustable_filename(ecl_core.path_max); buffer = ecl_filename_self(s); ecl_disable_interrupts(); hnd = GetModuleHandle("ecl.dll"); - len = ecl_GetModuleFileName(hnd, buffer, cl_core.path_max-1); + len = ecl_GetModuleFileName(hnd, buffer, ecl_core.path_max-1); ecl_enable_interrupts(); if (len == 0) { FEerror("GetModuleFileName failed (last error = ~S)", @@ -1125,9 +1125,9 @@ si_get_library_pathname(void) s = current_dir(); } } - cl_core.library_pathname = ecl_decode_filename(s, ECL_NIL); + ecl_core.library_pathname = ecl_decode_filename(s, ECL_NIL); OUTPUT_UNCHANGED: - @(return cl_core.library_pathname); + @(return ecl_core.library_pathname); } @(defun ext::chdir (directory &optional (change_d_p_d ECL_T)) diff --git a/src/c/unixint.d b/src/c/unixint.d index adf30aa97cfc9edcc1fa9d5c7e64d4a867ad0c1e..f53014ba25645cad79accab6fe17f6f68ccb7701 100644 --- a/src/c/unixint.d +++ b/src/c/unixint.d @@ -41,7 +41,7 @@ * sections of code which are interruptible, and in which it is safe * for the handler to run arbitrary code, protect anything else. In * principle this "marking" can be done using POSIX functions such as - * pthread_sigmask() or sigprocmask(). + * pthread_sigmask() or sigprocmask() abstracted with ecl_sigmask(). * * However in practice this is slow, as it involves at least a * function call, resolving thread-local variables, etc, etc, and it @@ -257,7 +257,7 @@ static ECL_INLINE bool interrupts_disabled_by_lisp(cl_env_ptr the_env) { return !ecl_option_values[ECL_OPT_BOOTED] || - Null(ECL_SYM_VAL(the_env, @'ext::*interrupts-enabled*')); + Null(ECL_SYM_VAL(the_env, ECL_INTERRUPTS_ENABLED)); } static void early_signal_error() ecl_attr_noreturn; @@ -265,8 +265,8 @@ static void early_signal_error() ecl_attr_noreturn; static void early_signal_error() { - ecl_internal_error("Got signal before environment was installed" - " on our thread"); + ecl_internal_error + ("Got signal before environment was installed on our thread"); } static void illegal_signal_code(cl_object code) ecl_attr_noreturn; @@ -307,11 +307,7 @@ unblock_signal(cl_env_ptr the_env, int signal) * We do not really "unblock" the signal, but rather restore * ECL's default sigmask. */ -# ifdef ECL_THREADS - pthread_sigmask(SIG_SETMASK, the_env->default_sigmask, NULL); -# else - sigprocmask(SIG_SETMASK, the_env->default_sigmask, NULL); -# endif + ecl_sigmask(SIG_SETMASK, the_env->default_sigmask, NULL); } #endif @@ -366,15 +362,14 @@ handle_all_queued(cl_env_ptr env) static void handle_all_queued_interrupt_safe(cl_env_ptr env) { - /* We have to save and later restore thread-local variables to - * ensure that they don't get overwritten by the interrupting - * code */ - /* INV: - IHS stack manipulations are interrupt safe - * - The rest of the thread local variables are - * guaranteed to be used in an interrupt safe way. This - * is not true for the compiler environment and ffi - * data, but it is unclear whether the DFFI or compiler - * are thread safe anyway. */ + /* We have to save and later restore thread-local variables to ensure that + * they don't get overwritten by the interrupting code. */ + /* FIXME introduce save/load procedure in modules. */ + /* INV IHS stack manipulations are interrupt safe; the rest of the thread + * local variables are guaranteed to be used in an interrupt safe way[1]. + * + * [1] This is not true for the compiler environment and ffi data, but it is + * unclear whether the DFFI or the compiler are thread safe anyway. */ cl_object fun = env->function; cl_index nvalues = env->nvalues; cl_object values[ECL_MULTIPLE_VALUES_LIMIT]; @@ -387,28 +382,29 @@ handle_all_queued_interrupt_safe(cl_env_ptr env) * not init and clear them before calling the interrupting * code we would risk memory leaks. */ cl_object big_register[ECL_BIGNUM_REGISTER_NUMBER]; - memcpy(big_register, env->big_register, ECL_BIGNUM_REGISTER_NUMBER*sizeof(cl_object)); + cl_index big_register_size = ECL_BIGNUM_REGISTER_NUMBER*sizeof(cl_object); + ecl_copy(big_register, env->big_register, big_register_size); ecl_init_bignum_registers(env); - /* We might have been interrupted while we push/pop in the - * stack. Increasing env->stack_top ensures that we don't - * overwrite the topmost stack value. */ - env->stack_top++; + /* We might have been interrupted while we push/pop in the stack. Increasing + * env->run_stack.top ensures that we don't overwrite the topmost stack + * value. */ + env->run_stack.top++; /* We also need to save and restore the (top+1)'th frame and * binding stack value to prevent overwriting it. * INV: Due to the stack safety areas we don't need to check * for env->frs/bds_limit */ struct ecl_frame top_frame; - memcpy(&top_frame, env->frs_top+1, sizeof(struct ecl_frame)); + memcpy(&top_frame, env->frs_stack.top+1, sizeof(struct ecl_frame)); struct ecl_bds_frame top_binding; - memcpy(&top_binding, env->bds_top+1, sizeof(struct ecl_bds_frame)); + memcpy(&top_binding, env->bds_stack.top+1, sizeof(struct ecl_bds_frame)); /* Finally we can handle the queued signals ... */ handle_all_queued(env); /* ... and restore everything again */ - memcpy(env->bds_top+1, &top_binding, sizeof(struct ecl_bds_frame)); - memcpy(env->frs_top+1, &top_frame, sizeof(struct ecl_frame)); - env->stack_top--; - ecl_clear_bignum_registers(env); - memcpy(env->big_register, big_register, ECL_BIGNUM_REGISTER_NUMBER*sizeof(cl_object)); + memcpy(env->bds_stack.top+1, &top_binding, sizeof(struct ecl_bds_frame)); + memcpy(env->frs_stack.top+1, &top_frame, sizeof(struct ecl_frame)); + env->run_stack.top--; + ecl_free_bignum_registers(env); + ecl_copy(env->big_register, big_register, big_register_size); env->packages_to_be_created_p = packages_to_be_created_p; env->packages_to_be_created = packages_to_be_created; env->stack_frame = stack_frame; @@ -445,8 +441,7 @@ queue_signal(cl_env_ptr env, cl_object code, int allocate) ECL_RPLACA(record, code); ECL_RPLACD(record, ECL_NIL); env->interrupt_struct->pending_interrupt = - ecl_nconc(env->interrupt_struct->pending_interrupt, - record); + ecl_nconc(env->interrupt_struct->pending_interrupt, record); } #ifdef ECL_THREADS @@ -535,7 +530,7 @@ handler_fn_prototype(non_evil_signal_handler, int sig, siginfo_t *siginfo, void unlikely_if (zombie_process(the_env)) return; signal_object = ecl_gethash_safe(ecl_make_fixnum(sig), - cl_core.known_signals, + ecl_core.known_signals, ECL_NIL); handle_or_queue(the_env, signal_object, sig); errno = old_errno; @@ -553,7 +548,7 @@ handler_fn_prototype(evil_signal_handler, int sig, siginfo_t *siginfo, void *dat unlikely_if (zombie_process(the_env)) return; signal_object = ecl_gethash_safe(ecl_make_fixnum(sig), - cl_core.known_signals, + ecl_core.known_signals, ECL_NIL); handle_signal_now(signal_object); errno = old_errno; @@ -620,7 +615,7 @@ asynchronous_signal_servicing_thread() sigdelset(&handled_set, SIGSEGV); sigdelset(&handled_set, SIGBUS); } - pthread_sigmask(SIG_BLOCK, &handled_set, NULL); + ecl_sigmask(SIG_BLOCK, &handled_set, NULL); } /* * We create the object for communication. We need a lock to prevent other @@ -648,7 +643,7 @@ asynchronous_signal_servicing_thread() break; } signal_code = ecl_gethash_safe(ecl_make_fixnum(signal_thread_msg.signo), - cl_core.known_signals, + ecl_core.known_signals, ECL_NIL); if (!Null(signal_code)) { mp_process_run_function(3, @'si::handle-signal', @@ -829,16 +824,16 @@ handler_fn_prototype(sigsegv_handler, int sig, siginfo_t *info, void *aux) # endif /* ECL_USE_MPROTECT */ # ifdef ECL_DOWN_STACK if (sig == SIGSEGV && - (char*)info->si_addr > the_env->cs_barrier && - (char*)info->si_addr <= the_env->cs_org) { + (char*)info->si_addr > the_env->c_stack.max && + (char*)info->si_addr <= the_env->c_stack.org) { unblock_signal(the_env, sig); ecl_unrecoverable_error(the_env, stack_overflow_msg); return; } # else if (sig == SIGSEGV && - (char*)info->si_addr < the_env->cs_barrier && - (char*)info->si_addr >= the_env->cs_org) { + (char*)info->si_addr < the_env->c_stack.max && + (char*)info->si_addr >= the_env->c_stack.org) { unblock_signal(the_env, sig); ecl_unrecoverable_error(the_env, stack_overflow_msg); return; @@ -870,7 +865,7 @@ cl_object si_check_pending_interrupts(void) { const cl_env_ptr the_env = ecl_process_env(); - handle_all_queued(ecl_process_env()); + handle_all_queued(the_env); ecl_return0(the_env); } @@ -907,25 +902,25 @@ do_catch_signal(int code, cl_object action, cl_object process) return ECL_T; } else { sigset_t handled_set; - pthread_sigmask(SIG_SETMASK, NULL, &handled_set); + ecl_sigmask(SIG_SETMASK, NULL, &handled_set); if (action == @':mask') { sigaddset(&handled_set, code); } else { sigdelset(&handled_set, code); } - pthread_sigmask(SIG_SETMASK, &handled_set, NULL); + ecl_sigmask(SIG_SETMASK, &handled_set, NULL); return ECL_T; } # else { sigset_t handled_set; - sigprocmask(SIG_SETMASK, NULL, &handled_set); + ecl_sigmask(SIG_SETMASK, NULL, &handled_set); if (action == @':mask') { sigaddset(&handled_set, code); } else { sigdelset(&handled_set, code); } - sigprocmask(SIG_SETMASK, &handled_set, NULL); + ecl_sigmask(SIG_SETMASK, &handled_set, NULL); return ECL_T; } # endif /* !ECL_THREADS */ @@ -951,8 +946,7 @@ do_catch_signal(int code, cl_object action, cl_object process) } return ECL_T; } else { - FEerror("Unknown 2nd argument to EXT:CATCH-SIGNAL: ~A", 1, - action); + FEerror("Unknown 2nd argument to EXT:CATCH-SIGNAL: ~A", 1, action); } } @@ -960,7 +954,7 @@ cl_object si_get_signal_handler(cl_object code) { const cl_env_ptr the_env = ecl_process_env(); - cl_object handler = ecl_gethash_safe(code, cl_core.known_signals, OBJNULL); + cl_object handler = ecl_gethash_safe(code, ecl_core.known_signals, OBJNULL); unlikely_if (handler == OBJNULL) { illegal_signal_code(code); } @@ -971,11 +965,11 @@ cl_object si_set_signal_handler(cl_object code, cl_object handler) { const cl_env_ptr the_env = ecl_process_env(); - cl_object action = ecl_gethash_safe(code, cl_core.known_signals, OBJNULL); + cl_object action = ecl_gethash_safe(code, ecl_core.known_signals, OBJNULL); unlikely_if (action == OBJNULL) { illegal_signal_code(code); } - ecl_sethash(code, cl_core.known_signals, handler); + ecl_sethash(code, ecl_core.known_signals, handler); si_catch_signal(2, code, ECL_T); ecl_return0(the_env); } @@ -985,7 +979,7 @@ si_set_signal_handler(cl_object code, cl_object handler) { const cl_env_ptr the_env = ecl_process_env(); int code_int; - unlikely_if (ecl_gethash_safe(code, cl_core.known_signals, OBJNULL) == OBJNULL) { + unlikely_if (ecl_gethash_safe(code, ecl_core.known_signals, OBJNULL) == OBJNULL) { illegal_signal_code(code); } code_int = ecl_fixnum(code); @@ -993,19 +987,16 @@ si_set_signal_handler(cl_object code, cl_object handler) # ifdef SIGSEGV unlikely_if ((code == ecl_make_fixnum(SIGSEGV)) && ecl_option_values[ECL_OPT_INCREMENTAL_GC]) - FEerror("It is not allowed to change the behavior of SIGSEGV.", - 0); + FEerror("It is not allowed to change the behavior of SIGSEGV.", 0); # endif # ifdef SIGBUS unlikely_if (code_int == SIGBUS) - FEerror("It is not allowed to change the behavior of SIGBUS.", - 0); + FEerror("It is not allowed to change the behavior of SIGBUS.", 0); # endif #endif #if defined(ECL_THREADS) && !defined(ECL_MS_WINDOWS_HOST) unlikely_if (code_int == ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]) { - FEerror("It is not allowed to change the behavior of signal ~D", 1, - code); + FEerror("It is not allowed to change the behavior of signal ~D", 1, code); } #endif #ifdef SIGFPE @@ -1037,40 +1028,34 @@ wakeup_noop(ULONG_PTR foo) static bool do_interrupt_thread(cl_object process) { + cl_env_ptr process_env = process->process.env; # ifdef ECL_WINDOWS_THREADS # ifndef ECL_USE_GUARD_PAGE # error "Cannot implement ecl_interrupt_process without guard pages" # endif - HANDLE thread = process->process.thread; + HANDLE thread = process_env->thread; CONTEXT context; - void *trap_address = process->process.env; + void *trap_address = ecl_cast_ptr(void*, process_env);; DWORD guard = PAGE_GUARD | PAGE_READWRITE; int ok = 1; if (SuspendThread(thread) == (DWORD)-1) { - FEwin32_error("Unable to suspend thread ~A", 1, - process); + FEwin32_error("Unable to suspend thread ~A", 1, process); ok = 0; goto EXIT; } - process->process.interrupt = ECL_T; - if (!VirtualProtect(process->process.env, - sizeof(struct cl_env_struct), - guard, - &guard)) + process_env->interrupt_struct->inside_interrupt = true; + if (!VirtualProtect(process_env, sizeof(struct cl_env_struct), guard, &guard)) { - FEwin32_error("Unable to protect memory from thread ~A", - 1, process); + FEwin32_error("Unable to protect memory from thread ~A", 1, process); ok = 0; } RESUME: if (!QueueUserAPC(wakeup_function, thread, 0)) { - FEwin32_error("Unable to queue APC call to thread ~A", - 1, process); + FEwin32_error("Unable to queue APC call to thread ~A", 1, process); ok = 0; } if (ResumeThread(thread) == (DWORD)-1) { - FEwin32_error("Unable to resume thread ~A", 1, - process); + FEwin32_error("Unable to resume thread ~A", 1, process); ok = 0; goto EXIT; } @@ -1078,9 +1063,8 @@ do_interrupt_thread(cl_object process) return ok; # else int signal = ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]; - if (pthread_kill(process->process.thread, signal)) { - FElibc_error("Unable to interrupt process ~A", 1, - process); + if (pthread_kill(process_env->thread, signal)) { + FElibc_error("Unable to interrupt process ~A", 1, process); } return 1; # endif @@ -1121,10 +1105,10 @@ void ecl_wakeup_process(cl_object process) { # ifdef ECL_WINDOWS_THREADS - HANDLE thread = process->process.thread; + cl_env_ptr process_env = process->process.env; + HANDLE thread = process_env->thread; if (!QueueUserAPC(wakeup_noop, thread, 0)) { - FEwin32_error("Unable to queue APC call to thread ~A", - 1, process); + FEwin32_error("Unable to queue APC call to thread ~A", 1, process); } # else do_interrupt_thread(process); @@ -1146,9 +1130,8 @@ _ecl_w32_exception_filter(struct _EXCEPTION_POINTERS* ep) { /* Access to guard page */ case STATUS_GUARD_PAGE_VIOLATION: { - cl_object process = the_env->own_process; - if (!Null(process->process.interrupt)) { - process->process.interrupt = ECL_NIL; + if(the_env->interrupt_struct->inside_interrupt) { + the_env->interrupt_struct->inside_interrupt = false; handle_all_queued_interrupt_safe(the_env); } return EXCEPTION_CONTINUE_EXECUTION; @@ -1208,8 +1191,7 @@ static cl_object W32_handle_in_new_thread(cl_object signal_code) { int outside_ecl = ecl_import_current_thread(@'si::handle-signal', ECL_NIL); - mp_process_run_function(3, @'si::handle-signal', - @'si::handle-signal', + mp_process_run_function(3, @'si::handle-signal', @'si::handle-signal', signal_code); if (outside_ecl) ecl_release_current_thread(); } @@ -1313,13 +1295,9 @@ install_asynchronous_signal_handlers() # endif #endif #ifdef HAVE_SIGPROCMASK - sigset_t *sigmask = cl_core.default_sigmask = &main_thread_sigmask; - cl_core.default_sigmask_bytes = sizeof(sigset_t); -# ifdef ECL_THREADS - pthread_sigmask(SIG_SETMASK, NULL, sigmask); -# else - sigprocmask(SIG_SETMASK, NULL, sigmask); -# endif + sigset_t *sigmask = ecl_core.first_env->default_sigmask = &main_thread_sigmask; + ecl_core.default_sigmask_bytes = sizeof(sigset_t); + ecl_sigmask(SIG_SETMASK, NULL, sigmask); #endif #if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK) ecl_mutex_init(&signal_thread_lock, TRUE); @@ -1330,11 +1308,7 @@ install_asynchronous_signal_handlers() } #endif #ifdef HAVE_SIGPROCMASK -# if defined(ECL_THREADS) - pthread_sigmask(SIG_SETMASK, sigmask, NULL); -# else - sigprocmask(SIG_SETMASK, sigmask, NULL); -# endif + ecl_sigmask(SIG_SETMASK, sigmask, NULL); #endif #ifdef ECL_WINDOWS_THREADS old_W32_exception_filter = @@ -1357,19 +1331,13 @@ install_signal_handling_thread() ecl_process_env()->default_sigmask = &main_thread_sigmask; if (ecl_option_values[ECL_OPT_SIGNAL_HANDLING_THREAD]) { cl_object fun = - ecl_make_cfun((cl_objectfn_fixed) - asynchronous_signal_servicing_thread, - @'si::signal-servicing', - ECL_NIL, - 0); + ecl_make_cfun((cl_objectfn_fixed) asynchronous_signal_servicing_thread, + @'si::signal-servicing', ECL_NIL, 0); cl_object process = signal_thread_process = - mp_process_run_function_wait(2, - @'si::signal-servicing', - fun); + mp_process_run_function_wait(2, @'si::signal-servicing', fun); if (Null(process)) { - ecl_internal_error("Unable to create signal " - "servicing thread"); + ecl_internal_error("Unable to create signal servicing thread."); } } #endif @@ -1417,13 +1385,12 @@ install_synchronous_signal_handlers() int signal = ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]; if (signal == 0) { signal = DEFAULT_THREAD_INTERRUPT_SIGNAL; - ecl_set_option(ECL_OPT_THREAD_INTERRUPT_SIGNAL, - signal); + ecl_set_option(ECL_OPT_THREAD_INTERRUPT_SIGNAL, signal); } mysignal(signal, process_interrupt_handler); #ifdef HAVE_SIGPROCMASK sigdelset(&main_thread_sigmask, signal); - pthread_sigmask(SIG_SETMASK, &main_thread_sigmask, NULL); + ecl_sigmask(SIG_SETMASK, &main_thread_sigmask, NULL); #endif } #endif @@ -1473,15 +1440,14 @@ static void create_signal_code_constants() { cl_object hash = - cl_core.known_signals = + ecl_core.known_signals = cl__make_hash_table(@'eql', ecl_make_fixnum(128), - cl_core.rehash_size, - cl_core.rehash_threshold); + ecl_ct_default_rehash_size, + ecl_ct_default_rehash_threshold); int i; for (i = 0; known_signals[i].code >= 0; i++) { add_one_signal(hash, known_signals[i].code, - _ecl_intern(known_signals[i].name, - cl_core.ext_package), + _ecl_intern(known_signals[i].name, cl_core.ext_package), known_signals[i].handler); } #ifdef SIGRTMIN @@ -1504,17 +1470,108 @@ create_signal_code_constants() #endif } -void -init_unixint(int pass) +/* -- module definition ------------------------------------------------------ */ + +static cl_object +create_unixint() +{ + cl_env_ptr the_env = ecl_core.first_env; + the_env->default_sigmask = NULL; + the_env->interrupt_struct = NULL; + ecl_disable_interrupts_env(the_env); + /* Install handlers */ + install_asynchronous_signal_handlers(); + install_synchronous_signal_handlers(); + return ECL_NIL; +} + +static cl_object +enable_unixint() { - if (pass == 0) { - install_asynchronous_signal_handlers(); - install_synchronous_signal_handlers(); + create_signal_code_constants(); + install_fpe_signal_handlers(); + install_signal_handling_thread(); + ECL_SET(ECL_INTERRUPTS_ENABLED, ECL_T); + ecl_process_env()->disable_interrupts = 0; + return ECL_NIL; +} + +static cl_object +init_env_unixint(cl_env_ptr the_env) +{ + cl_env_ptr parent_env = ecl_process_env_unsafe(); + size_t bytes = ecl_core.default_sigmask_bytes; + if (bytes == 0) { + the_env->default_sigmask = 0; + } else if (parent_env) { + the_env->default_sigmask = ecl_alloc_atomic(bytes); + memcpy(the_env->default_sigmask, parent_env->default_sigmask, bytes); } else { - create_signal_code_constants(); - install_fpe_signal_handlers(); - install_signal_handling_thread(); - ECL_SET(@'ext::*interrupts-enabled*', ECL_T); - ecl_process_env()->disable_interrupts = 0; + the_env->default_sigmask = ecl_core.first_env->default_sigmask; } + the_env->interrupt_struct = ecl_alloc(sizeof(*the_env->interrupt_struct)); + the_env->interrupt_struct->pending_interrupt = ECL_NIL; +#ifdef ECL_THREADS + ecl_mutex_init(&the_env->interrupt_struct->signal_queue_lock, FALSE); +#endif +#ifdef ECL_WINDOWS_THREADS + the_env->interrupt_struct->inside_interrupt = false; +#endif + { + int size = ecl_option_values[ECL_OPT_SIGNAL_QUEUE_SIZE]; + the_env->interrupt_struct->signal_queue = cl_make_list(1, ecl_make_fixnum(size)); + } + the_env->fault_address = the_env; + the_env->trap_fpe_bits = 0; + /* An fresh environment _always_ disables interrupts. They are activated later + * on by the thread entry point or ecl_module_unixint. */ + ecl_disable_interrupts_env(the_env); + return ECL_NIL; } + +static cl_object +init_cpu_unixint(cl_env_ptr the_env) +{ + return ECL_NIL; +} + +static cl_object +free_cpu_unixint(cl_env_ptr the_env) +{ + ecl_disable_interrupts_env(the_env); + return ECL_NIL; +} + +static cl_object +free_env_unixint(cl_env_ptr the_env) +{ +#ifdef ECL_THREADS + ecl_mutex_destroy(&the_env->interrupt_struct->signal_queue_lock); +#endif + return ECL_NIL; +} + +/* KLUDGE UNIXINT and MEM_GC are interwened - GC expects stop_world to work and + unixint relies on the GC to allocate its internal structures. + + When we start add MEM_GC module before UNIXINT and enable GC after both are + created. That is enough to get GC going. Finally we enable UNIXINT. + + When we adopt a new cpu we first disable MEM_GC, then initialize UNIXINT + (allocator works fine despite GC collector being disabled), then initialize + GC to register the current thread and enable the GC. -- jd 2024-12-05 */ + +ecl_def_ct_base_string(str_unixint, "UNIXINT", 7, static, const); +static struct ecl_module module_unixint = { + .name = str_unixint, + .create = create_unixint, + .enable = enable_unixint, + .init_env = init_env_unixint, + .init_cpu = init_cpu_unixint, + .free_cpu = free_cpu_unixint, + .free_env = free_env_unixint, + .disable = ecl_module_no_op, + .destroy = ecl_module_no_op +}; + +cl_object ecl_module_unixint = (cl_object)&module_unixint; diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index fbc3686f71a424ffea7c7c7f4e4915fe652955e0..45f93cf980a3c9bdd701fc5c8ed00ba25fdf3a05 100644 --- a/src/clos/conditions.lsp +++ b/src/clos/conditions.lsp @@ -88,15 +88,6 @@ :function f))) *restart-clusters*))) -(defun bind-simple-handlers (tag names) - (flet ((simple-handler-function (tag code) - #'(lambda (c) (throw tag (values code c))))) - (cons (loop for i from 1 - for n in (if (atom names) (list names) names) - for f = (simple-handler-function tag i) - collect (cons n f)) - *handler-clusters*))) - (defmacro restart-bind (bindings &body forms) `(let ((*restart-clusters* (cons (list ,@(mapcar #'(lambda (binding) @@ -382,28 +373,33 @@ |# -(defparameter *handler-clusters* nil) +(defvar *signal-handlers* nil) -(defmacro handler-bind (bindings &body forms) - (unless (every #'(lambda (x) (and (listp x) (= (length x) 2))) bindings) - (error "Ill-formed handler bindings.")) - `(let ((*handler-clusters* - (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x))) - bindings)) - *handler-clusters*))) - ,@forms)) +(defmacro handler-bind (bindings &body body) + (with-gensyms (handler condition) + `(flet ((,handler (,condition) + (typecase ,condition + ,@(loop for (type func . rest) in bindings + when rest do + (error "Ill-formed handler bindings.") + collect `(,type (funcall ,func ,condition)))))) + (declare (dynamic-extent (function ,handler))) + (let ((*signal-handlers* (cons (function ,handler) *signal-handlers*))) + ,@body)))) + +(defun bind-simple-handlers (tag names) + (flet ((simple-handler (condition) + (loop for code from 1 + for type in (if (atom names) (list names) names) + when (typep condition type) do + (throw tag (values code condition))))) + (cons #'simple-handler *signal-handlers*))) (defun signal (datum &rest arguments) - (let* ((condition - (coerce-to-condition datum arguments 'SIMPLE-CONDITION 'SIGNAL)) - (*handler-clusters* *handler-clusters*)) + (let ((condition (coerce-to-condition datum arguments 'SIMPLE-CONDITION 'SIGNAL))) (when (typep condition *break-on-signals*) (break "~A~%Break entered because of *BREAK-ON-SIGNALS*." condition)) - (loop (unless *handler-clusters* (return)) - (let ((cluster (pop *handler-clusters*))) - (dolist (handler cluster) - (when (typep condition (car handler)) - (funcall (cdr handler) condition))))) + (%signal condition t nil) nil)) @@ -879,10 +875,5 @@ strings." (signal condition) (invoke-debugger condition)))))) -(defun sys::stack-error-handler (continue-string datum args) - (unwind-protect (universal-error-handler continue-string datum args) - (si:reset-margin - (getf args :type)))) - (defun sys::tpl-continue-command (&rest any) (apply #'invoke-restart 'continue any)) diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index 9ab0f07cefd21283ee07f002252ea004a7b4d1e8..4993a8ed41692124565c1991c349eceec0a59e34 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -15,11 +15,6 @@ ;;; --------------------------------------------------------------------- ;;; Fixup -;;; Early version of the stack handler. -(defun sys::stack-error-handler (continue-string datum args) - (declare (ignore continue-string)) - (apply #'error datum args)) - (defun register-method-with-specializers (method) (declare (si::c-local)) (with-early-accessors (+standard-method-slots+ +specializer-slots+) diff --git a/src/clos/hierarchy.lsp b/src/clos/hierarchy.lsp index 0e2690d584c9d1fd01d4bf2f7c02c7eed90d6561..18e887aac0dfe6602426433fc90f53e1a83bd434 100644 --- a/src/clos/hierarchy.lsp +++ b/src/clos/hierarchy.lsp @@ -229,6 +229,8 @@ (si::code-block) (si::foreign-data) (si::frame) + (si::exception) + (si::module) (si::weak-pointer) #+threads (mp::process) #+threads (mp::lock) diff --git a/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp b/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp index 6516c7c403669c83e9672e0aedf5d75bdcd0b356..107a1dc8d8ff1c3a06f28d757cb5fed89fea640e 100644 --- a/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp +++ b/src/cmp/cmpbackend-cxx/cmpc-opt-ct.lsp @@ -42,12 +42,12 @@ '( ;; Order is important: on platforms where 0.0 and -0.0 are the same ;; the last one is prioritized. - (#.(coerce 0 'cl:single-float) "cl_core.singlefloat_zero") - (#.(coerce 0 'cl:double-float) "cl_core.doublefloat_zero") - (#.(coerce -0.0 'cl:single-float) "cl_core.singlefloat_minus_zero") - (#.(coerce -0.0 'cl:double-float) "cl_core.doublefloat_minus_zero") - (#.(coerce 0 'cl:long-float) "cl_core.longfloat_zero") - (#.(coerce -0.0 'cl:long-float) "cl_core.longfloat_minus_zero") + (#.(coerce 0 'cl:single-float) "ecl_ct_singlefloat_zero") + (#.(coerce 0 'cl:double-float) "ecl_ct_doublefloat_zero") + (#.(coerce -0.0 'cl:single-float) "ecl_ct_singlefloat_minus_zero") + (#.(coerce -0.0 'cl:double-float) "ecl_ct_doublefloat_minus_zero") + (#.(coerce 0 'cl:long-float) "ecl_ct_longfloat_zero") + (#.(coerce -0.0 'cl:long-float) "ecl_ct_longfloat_minus_zero") ;; We temporarily remove this constant, because the bytecodes compiler ;; does not know how to externalize it. diff --git a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp index f652e7058a94eab1b435689994dc90c65f0d8b64..cb8567f7b1705c92f82604106b1664c28a9c92f3 100644 --- a/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp +++ b/src/cmp/cmpbackend-cxx/cmppass2-cont.lsp @@ -149,7 +149,7 @@ (wt-nl "volatile bool unwinding = FALSE;") (wt-nl "ecl_frame_ptr next_fr;") (with-unwind-frame ("ECL_PROTECT_TAG") - (wt-nl " unwinding = TRUE; next_fr=cl_env_copy->nlj_fr;") + (wt-nl " unwinding = TRUE; next_fr=cl_env_copy->frs_stack.nlj_fr;") (let ((*destination* 'VALUEZ)) (c2expr* form))) (wt-nl "ecl_frs_pop(cl_env_copy);") diff --git a/src/configure b/src/configure index f1ace37a3f58939fd42240517e147dc4e84ee27a..b1c1d954a8aebbe98d5771c8f161d174babfca0b 100755 --- a/src/configure +++ b/src/configure @@ -6092,9 +6092,10 @@ SHAREDPREFIX='lib' LIBPREFIX='lib' LIBEXT='a' PICFLAG='-fPIC' -THREAD_CFLAGS='' +THREAD_CFLAGS='-DGC_NO_THREAD_REDIRECTS' THREAD_LIBS='' THREAD_GC_FLAGS='--enable-threads=posix' +CFLAGS='' INSTALL_TARGET='install' THREAD_OBJ="$THREAD_OBJ threads/thread threads/mutex threads/condition_variable threads/semaphore threads/barrier threads/mailbox threads/rwlock" clibs='-lm' @@ -6103,7 +6104,7 @@ SONAME_LDFLAGS='' case "${host_os}" in linux-android*) thehost='android' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" # THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -6121,7 +6122,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" # libdir may have a dollar expression inside linux*) thehost='linux' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -6134,7 +6135,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" ;; gnu*) thehost='gnu' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -6146,7 +6147,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" ;; kfreebsd*-gnu) thehost='kfreebsd' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -6188,8 +6189,6 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" ;; openbsd*) thehost='openbsd' - THREAD_CFLAGS='' - THREAD_LIBS='' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH="-Wl,--rpath,~A" @@ -6217,7 +6216,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" thehost='cygwin' #enable_threads='no' shared='yes' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -6236,7 +6235,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" clibs='' shared='yes' enable_threads='yes' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_GC_FLAGS='--enable-threads=win32' SHARED_LDFLAGS="-Wl,--stack,${ECL_DEFAULT_C_STACK_SIZE}" BUNDLE_LDFLAGS="-Wl,--stack,${ECL_DEFAULT_C_STACK_SIZE}" @@ -6254,7 +6253,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" SHARED_LDFLAGS="-dynamiclib ${LDFLAGS}" BUNDLE_LDFLAGS="-bundle ${LDFLAGS}" ECL_LDRPATH='-Wl,-rpath,~A' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' # The GMP library has not yet been ported to Intel or Arm-OSX case "`uname -m`" in @@ -6287,7 +6286,7 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" thehost='nonstop' shared='yes' PICFLAG='-call_shared' - THREAD_CFLAGS='-spthread' + THREAD_CFLAGS="-spthread ${THREAD_CFLAGS}" SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH='-Wld=\"-rld_l ~A\"' @@ -6295,7 +6294,6 @@ LSP_FEATURES="(cons :android ${LSP_FEATURES})" ;; haiku*) thehost='haiku' - THREAD_LIBS='' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" ECL_LDRPATH="-Wl,--rpath,~A" @@ -6322,7 +6320,7 @@ esac case "${host}" in *-nacl) thehost='linux' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' SHARED_LDFLAGS="-shared ${LDFLAGS}" BUNDLE_LDFLAGS="-shared ${LDFLAGS}" @@ -6336,7 +6334,7 @@ LSP_FEATURES="(cons :nacl ${LSP_FEATURES})" ;; *-pnacl) thehost='linux' - THREAD_CFLAGS='-D_THREAD_SAFE' + THREAD_CFLAGS="-D_THREAD_SAFE ${THREAD_CFLAGS}" THREAD_LIBS='-lpthread' CFLAGS="-D_GNU_SOURCE -D_FILE_OFFSET_BITS=64 ${CFLAGS}" @@ -7008,7 +7006,7 @@ if test "${enable_threads}" = "yes" ; then as_fn_error $? "Threads aren't supported on this system." "$LINENO" 5 else LIBS="${THREAD_LIBS} ${LIBS}" - CFLAGS="${CFLAGS} ${THREAD_CFLAGS}" + CFLAGS="${CFLAGS} ${THREAD_CFLAGS} -DGC_NO_THREAD_REDIRECTS" ac_fn_c_check_func "$LINENO" "pthread_rwlock_init" "ac_cv_func_pthread_rwlock_init" if test "x$ac_cv_func_pthread_rwlock_init" = xyes @@ -7060,8 +7058,6 @@ fi if test ${enable_boehm} = "no" ; then as_fn_error $? "Boehm GC library is currently needed to build ECL" "$LINENO" 5; - EXTRA_OBJS="${EXTRA_OBJS} alloc.${OBJEXT} gbc.${OBJEXT}" - enable_smallcons="no" else @@ -7314,7 +7310,6 @@ printf "%s\n" "${system_boehm} " >&6; } fi else FASL_LIBS="${FASL_LIBS} -lgc" - EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}" printf "%s\n" "#define GBC_BOEHM 1" >>confdefs.h @@ -7344,7 +7339,6 @@ printf "%s\n" "$as_me: Configuring included Boehm GC library:" >&6;} ECL_BOEHM_GC_HEADER='ecl/gc/gc.h' SUBDIRS="${SUBDIRS} gc" CORE_LIBS="-leclgc ${CORE_LIBS}" - EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}" if test "${enable_shared}" = "no"; then LIBRARIES="${LIBRARIES} ${LIBPREFIX}eclgc.${LIBEXT}" fi @@ -7492,7 +7486,6 @@ printf "%s\n" "$as_me: Configuring included libffi library:" >&6;} ECL_LIBFFI_HEADER='ecl/ffi.h' SUBDIRS="${SUBDIRS} libffi" CORE_LIBS="-leclffi ${CORE_LIBS}" - EXTRA_OBJS="${EXTRA_OBJS} alloc_2.${OBJEXT}" if test "${enable_shared}" = "no"; then LIBRARIES="${LIBRARIES} ${LIBPREFIX}eclffi.${LIBEXT}" fi diff --git a/src/configure.ac b/src/configure.ac index 309c03ea026390799805ddad0513b202a705bbff..b72773b79736e8ede817b52bbdc705a0fd3c25aa 100644 --- a/src/configure.ac +++ b/src/configure.ac @@ -600,8 +600,6 @@ dnl ---------------------------------------------------------------------- dnl Boehm-Weiser garbage collector if test ${enable_boehm} = "no" ; then AC_MSG_ERROR([Boehm GC library is currently needed to build ECL]); - EXTRA_OBJS="${EXTRA_OBJS} alloc.${OBJEXT} gbc.${OBJEXT}" - enable_smallcons="no" else ECL_BOEHM_GC fi diff --git a/src/h/ecl-inl.h b/src/h/ecl-inl.h index 16101fc939051182887a17f4655727e190f2c03f..e4f687a409d7a4c6131fad29f6b3422326591bfc 100644 --- a/src/h/ecl-inl.h +++ b/src/h/ecl-inl.h @@ -82,6 +82,26 @@ } else do { #define end_loop_for_on(list) } while (list = ECL_CONS_CDR(list), ECL_CONSP(list)) +/* + * Loops over a vector. + */ +#define loop_across_stack_fifo(var, obj) { \ + cl_index __ecl_idx; \ + cl_index __ecl_ndx = obj->vector.fillp; \ + cl_object *__ecl_v = obj->vector.self.t; \ + for(__ecl_idx = 0; __ecl_idx < __ecl_ndx; __ecl_idx++) { \ + cl_object var = __ecl_v[__ecl_idx]; + + +#define loop_across_stack_filo(var, obj) { \ + cl_index __ecl_idx; \ + cl_index __ecl_ndx = obj->vector.fillp; \ + cl_object *__ecl_v = obj->vector.self.t; \ + for(__ecl_idx = __ecl_ndx; __ecl_idx > 0; __ecl_idx--) { \ + cl_object var = __ecl_v[__ecl_idx-1]; + +#define end_loop_across_stack() }} + /* * Static constant definition. */ @@ -91,35 +111,91 @@ #define ecl_cast_ptr(type,n) ((type)(n)) #endif +#define ecl_constexpr_string(name) \ + ((struct ecl_base_string) \ + { (int8_t)t_base_string, 0, ecl_aet_bc, 0, ECL_NIL, \ + (cl_index)((sizeof(name)-1)), (cl_index)((sizeof(name)-1)), \ + (ecl_base_char*)(name) }) + +#ifdef ECL_THREADS +#define ecl_constexpr_symbol(type, name, value) \ + ((struct ecl_symbol) \ + { (int8_t)t_symbol, 0, type, 0, \ + value, ECL_NIL /*gfdef*/, NULL /*undefined_function_entry*/, \ + ECL_NIL, ECL_NIL, ECL_NIL, (cl_object)&ecl_constexpr_string(name), \ + ECL_NIL, ECL_NIL, ECL_MISSING_SPECIAL_BINDING } ) +#else +#define ecl_constexpr_symbol(type, name, value) \ + ((struct ecl_symbol) \ + { (int8_t)t_symbol, 0, type, 0, \ + value, ECL_NIL /*gfdef*/, NULL /*undefined_function_entry*/, \ + ECL_NIL, ECL_NIL, ECL_NIL, (cl_object)&ecl_constexpr_string(name), \ + ECL_NIL, ECL_NIL } ) +#endif + +#define ecl_def_variable(name, value, chars, len) \ + ecl_def_ct_base_string (name ## _var_name, chars, len,static,const); \ + ecl_def_ct_token(name, ecl_stp_special, name ## _var_name, value,,) + +#define ecl_def_constant(name, value, chars, len) \ + ecl_def_ct_base_string (name ## _var_name, chars, len,static,const); \ + ecl_def_ct_token(name, ecl_stp_constant, name ## _var_name, value,,const) + +#ifdef ECL_THREADS +#define ecl_def_ct_token(name,stype,sname,value,static,const) \ + static const struct ecl_symbol name ## _data = { \ + (int8_t)t_symbol, 0, stype, 0, \ + value, ECL_NIL, NULL /*ecl_undefined_function_entry*/, \ + ECL_NIL, ECL_NIL, ECL_NIL, sname, ECL_NIL, ECL_NIL, \ + ECL_MISSING_SPECIAL_BINDING }; \ + static const cl_object name = (cl_object)(& name ## _data) +#else +#define ecl_def_ct_token(name,stype,sname,value,static,const) \ + static const struct ecl_symbol name ## _data = { \ + (int8_t)t_symbol, 0, stype, 0, \ + value, ECL_NIL, NULL /*ecl_undefined_function_entry*/, \ + ECL_NIL, ECL_NIL, ECL_NIL, sname, ECL_NIL, ECL_NIL }; \ + static const cl_object name = (cl_object)(& name ## _data) +#endif + +#define ecl_def_function(name, cname, static, const) \ + static const struct ecl_cfunfixed name ##_data = { \ + (int8_t)t_cfunfixed, 0, 0, 0, \ + /*name*/ECL_NIL, /*block*/ECL_NIL, \ + /*entry*/(cl_objectfn)cname, \ + /*funfixed_entry*/(cl_objectfn_fixed)NULL, \ + ECL_NIL, ECL_NIL }; \ + static const cl_object name = (cl_object)(& name ## _data) + #define ecl_def_string_array(name,static,const) \ static const union { \ struct ecl_base_string elt; \ cl_fixnum padding[(sizeof(struct ecl_base_string)+3)/4*4]; \ } name[] -#define ecl_def_string_array_elt(chars) { { \ - (int8_t)t_base_string, 0, ecl_aet_bc, 0, \ - ECL_NIL, (cl_index)(sizeof(chars))-1, \ - (cl_index)(sizeof(chars))-1, \ +#define ecl_def_string_array_elt(chars) { { \ + (int8_t)t_base_string, 0, ecl_aet_bc, 0, \ + ECL_NIL, (cl_index)(sizeof(chars))-1, \ + (cl_index)(sizeof(chars))-1, \ (ecl_base_char*)(chars) } } -#define ecl_def_ct_base_string(name,chars,len,static,const) \ - static const struct ecl_base_string name ## _data = { \ +#define ecl_def_ct_base_string(name,chars,len,static,const) \ + static const struct ecl_base_string name ## _data = { \ (int8_t)t_base_string, 0, ecl_aet_bc, 0, \ - ECL_NIL, (cl_index)(len), (cl_index)(len), \ - (ecl_base_char*)(chars) }; \ + ECL_NIL, (cl_index)(len), (cl_index)(len), \ + (ecl_base_char*)(chars) }; \ static const cl_object name = (cl_object)(& name ## _data) -#define ecl_def_ct_single_float(name,f,static,const) \ - static const struct ecl_singlefloat name ## _data = { \ - (int8_t)t_singlefloat, 0, 0, 0, \ - (float)(f) }; \ +#define ecl_def_ct_single_float(name,f,static,const) \ + static const struct ecl_singlefloat name ## _data = { \ + (int8_t)t_singlefloat, 0, 0, 0, \ + (float)(f) }; \ static const cl_object name = (cl_object)(& name ## _data) -#define ecl_def_ct_double_float(name,f,static,const) \ - static const struct ecl_doublefloat name ## _data = { \ - (int8_t)t_doublefloat, 0, 0, 0, \ - (double)(f) }; \ +#define ecl_def_ct_double_float(name,f,static,const) \ + static const struct ecl_doublefloat name ## _data = { \ + (int8_t)t_doublefloat, 0, 0, 0, \ + (double)(f) }; \ static const cl_object name = (cl_object)(& name ## _data) #define ecl_def_ct_long_float(name,f,static,const) \ diff --git a/src/h/ecl.h b/src/h/ecl.h index ee1fca141717954f15ae349ad7689bf8132959f1..1fa4363df9d937c55e29d33d0b588330eff70058 100644 --- a/src/h/ecl.h +++ b/src/h/ecl.h @@ -62,13 +62,7 @@ # include # endif # ifdef ECL_THREADS - typedef HANDLE pthread_t; - typedef HANDLE pthread_mutex_t; - typedef HANDLE pthread_cond_t; /*Dummy, not really used*/ # undef ERROR -# ifdef GBC_BOEHM -# define CreateThread GC_CreateThread -# endif # else # error "The Windows ports cannot be built without threads." # endif /* ECL_THREADS */ @@ -80,6 +74,7 @@ #endif #include +#include #include #include #include diff --git a/src/h/external.h b/src/h/external.h index d2775591474563470cdca94712b9932f5f00d159..37cf6e5da3a1b8edf02ef09206d2b6bf1a64a6d0 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -10,118 +10,127 @@ extern "C" { #define _ECL_ARGS(x) x +/* The runtime stack, which is used mainly for keeping the arguments of a + * function before it is invoked, and also by the compiler and by the reader + * when they are building some data structure. */ +struct ecl_runtime_stack { + cl_index size; + cl_index limit_size; + cl_object *org; + cl_object *top; + cl_object *limit; +}; + +/* The BinDing Stack stores the bindings of special variables. */ +struct ecl_binding_stack { + cl_index size; + cl_index limit_size; + struct ecl_bds_frame *org; + struct ecl_bds_frame *top; + struct ecl_bds_frame *limit; +#ifdef ECL_THREADS + cl_index tl_bindings_size; + cl_object *tl_bindings; +#endif +}; + +struct ecl_frames_stack { + cl_index size; + cl_index limit_size; + struct ecl_frame *org; + struct ecl_frame *top; + struct ecl_frame *limit; + /* extra */ + struct ecl_frame *nlj_fr; + cl_index frame_id; +}; + +struct ecl_history_stack { + struct ecl_ihs_frame *top; +}; + +struct ecl_c_stack { + cl_index size; /* current size */ + cl_index limit_size; /* maximum size minus safety area */ + char *org; /* origin address */ + char *max; /* overflow address (real maximum address) */ + char *limit; /* overflow address (spares recovery area) */ + /* extra */ + cl_index max_size; /* maximum possible size */ +}; + + /* * Per-thread data. */ -typedef struct cl_env_struct *cl_env_ptr; struct cl_env_struct { - /* Flag for disabling interrupts while we call C library functions. */ - volatile int disable_interrupts; - - /* Array where values are returned by functions. */ + /* -- ECL runtime ---------------------------------------------------- */ + /* Array where values are returned. */ cl_index nvalues; cl_object values[ECL_MULTIPLE_VALUES_LIMIT]; + /* ECL stacks. */ + + /* The Runtime Stack is used mainly for keeping the arguments of a + * function before it is invoked, and also by the compiler and by the + * reader when they are building some data structure. */ + struct ecl_runtime_stack run_stack; + /* The BinDing Stack stores the bindings of special variables. */ + struct ecl_binding_stack bds_stack; + /* The FRames Stack (FRS) is a list of frames or jump points, and it is + * used by different high-level constructs (BLOCK, TAGBODY, CATCH...) + * to set return points. */ + struct ecl_frames_stack frs_stack; + /* The Invocation History Stack (IHS) keeps a list of the names of the + * functions that are invoked with their lexical environments. */ + struct ecl_history_stack ihs_stack; + /* The following pointers to the C Stack are used to ensure that a + * recursive function does not enter an infinite loop and exhausts all + * memory. They will eventually disappear, because most operating + * systems already take care of this. */ + struct ecl_c_stack c_stack; /* shadow stack */ + /* -- Invocation of closures, generic function, etc ------------------ */ cl_object function; cl_object stepper; /* Hook invoked by ByteVM */ cl_object stack_frame; /* Current stack frame */ - /* The four stacks in ECL. */ - - /* - * The lisp stack, which is used mainly for keeping the arguments of a - * function before it is invoked, and also by the compiler and by the - * reader when they are building some data structure. - */ - cl_index stack_size; - cl_index stack_limit_size; - cl_object *stack; - cl_object *stack_top; - cl_object *stack_limit; - - /* - * The BinDing Stack stores the bindings of special variables. - */ + /* -- System Processes (native threads) ------------------------------ */ #ifdef ECL_THREADS - cl_index thread_local_bindings_size; - cl_object *thread_local_bindings; - cl_object bindings_array; + cl_object own_process; /* Backpointer to the running process. */ + ecl_thread_t thread; #endif - cl_index bds_size; - cl_index bds_limit_size; - struct ecl_bds_frame *bds_org; - struct ecl_bds_frame *bds_top; - struct ecl_bds_frame *bds_limit; - - /* - * The Invocation History Stack (IHS) keeps a list of the names of the - * functions that are invoked, together with their lexical - * environments. - */ - struct ecl_ihs_frame *ihs_top; - - /* - * The FRames Stack (FRS) is a list of frames or jump points, and it - * is used by different high-level constructs (BLOCK, TAGBODY, CATCH...) - * to set return points. - */ - cl_index frs_size; - cl_index frs_limit_size; - struct ecl_frame *frs_org; - struct ecl_frame *frs_top; - struct ecl_frame *frs_limit; - struct ecl_frame *nlj_fr; - cl_index frame_id; - /* - * The following pointers to the C Stack are used to ensure that a - * recursive function does not enter an infinite loop and exhausts all - * memory. They will eventually disappear, because most operating - * systems already take care of this. - */ - cl_index cs_size; /* current size */ - cl_index cs_limit_size; /* current size minus safety area */ - cl_index cs_max_size; /* maximum possible size */ - char *cs_org; /* origin address */ - char *cs_limit; /* limit address; if the stack pointer - goes beyond this value, a stack - overflow will be signaled ... */ - char *cs_barrier; /* ... but the area up to cs_barrier - is still available to allow - programs to recover from the - stack overflow */ - - /* Private variables used by different parts of ECL: */ + /* -- System Interrupts ---------------------------------------------- */ + /* Flag for disabling interrupts while we call C library functions. */ + volatile int disable_interrupts; + /* The objects in this struct need to be writeable from a different + thread, if environment is write-protected by mprotect. Hence they + have to be allocated seperately. */ + struct ecl_interrupt_struct *interrupt_struct; + void *default_sigmask; + /* Floating point interrupts which are trapped */ + int trap_fpe_bits; + /* Segmentation fault address */ + void *fault_address; + + /* -- Private variables used by different parts of ECL ---------------- */ /* ... the reader and printer ... */ cl_object string_pool; - /* ... the compiler ... */ struct cl_compiler_env *c_env; - /* ... the formatter ... */ #if !defined(ECL_CMU_FORMAT) cl_object fmt_aux_stream; #endif - /* ... arithmetics ... */ cl_object big_register[ECL_BIGNUM_REGISTER_NUMBER]; - - cl_object own_process; - /* The objects in this struct need to be writeable from a - different thread, if environment is write-protected by - mprotect. Hence they have to be allocated seperately. */ - struct ecl_interrupt_struct *interrupt_struct; - void *default_sigmask; - - /* The following is a hash table for caching invocations of - generic functions. In a multithreaded environment we must - queue operations in which the hash is cleared from updated - generic functions. */ + /* The following is a hash table for caching invocations of generic + functions. In a multithreaded environment we must queue operations in + which the hash is cleared from updated generic functions. */ struct ecl_cache *method_cache; struct ecl_cache *slot_cache; - /* foreign function interface */ #ifdef HAVE_LIBFFI cl_index ffi_args_limit; @@ -129,21 +138,10 @@ struct cl_env_struct { union ecl_ffi_values *ffi_values; union ecl_ffi_values **ffi_values_ptrs; #endif - - /* Floating point interrupts which are trapped */ - int trap_fpe_bits; - /* List of packages interned when loading a FASL but which have * to be explicitely created by the compiled code itself. */ cl_object packages_to_be_created; cl_object packages_to_be_created_p; - - /* Segmentation fault address */ - void *fault_address; - -#ifdef ECL_THREADS - int cleanup; -#endif }; struct ecl_interrupt_struct { @@ -152,6 +150,9 @@ struct ecl_interrupt_struct { #ifdef ECL_THREADS ecl_mutex_t signal_queue_lock; #endif +#ifdef ECL_WINDOWS_THREADS + bool inside_interrupt; +#endif }; #ifndef __GNUC__ @@ -170,9 +171,7 @@ struct ecl_interrupt_struct { extern ECL_API cl_env_ptr cl_env_p; #endif -/* - * Per-process data. Modify main.d accordingly. - */ +/* Per-process data. Modify main.d accordingly. */ struct cl_core_struct { cl_object packages; @@ -189,9 +188,6 @@ struct cl_core_struct { cl_object c_package; cl_object ffi_package; - cl_object pathname_translations; - cl_object library_pathname; - cl_object terminal_io; cl_object null_stream; cl_object standard_input; @@ -201,65 +197,22 @@ struct cl_core_struct { cl_object dispatch_reader; cl_object char_names; - cl_object null_string; - - cl_object plus_half; - cl_object minus_half; - cl_object imag_unit; - cl_object minus_imag_unit; - cl_object imag_two; - cl_object singlefloat_zero; - cl_object doublefloat_zero; - cl_object singlefloat_minus_zero; - cl_object doublefloat_minus_zero; - cl_object longfloat_zero; - cl_object longfloat_minus_zero; cl_object gensym_prefix; cl_object gentemp_prefix; cl_object gentemp_counter; - cl_object Jan1st1970UT; - cl_object system_properties; - - cl_env_ptr first_env; -#ifdef ECL_THREADS - cl_object processes; - ecl_mutex_t processes_lock; - ecl_mutex_t global_lock; - ecl_mutex_t error_lock; - ecl_rwlock_t global_env_lock; -#endif - cl_object libraries; - - size_t max_heap_size; - cl_object bytes_consed; - cl_object gc_counter; - bool gc_stats; - int path_max; -#ifdef GBC_BOEHM - char *safety_region; -#endif - void *default_sigmask; - cl_index default_sigmask_bytes; - -#ifdef ECL_THREADS - cl_index last_var_index; - cl_object reused_indices; -#endif - cl_object slash; - cl_object compiler_dispatch; - - cl_object rehash_size; - cl_object rehash_threshold; - - cl_object known_signals; }; +extern ECL_API struct ecl_core_struct ecl_core; extern ECL_API struct cl_core_struct cl_core; +/* variables */ +extern ECL_API cl_object ecl_vr_shandlers; +extern ECL_API cl_object ecl_vr_allow_other_keys; + /* memory.c */ extern ECL_API void *ecl_malloc(cl_index n); extern ECL_API void *ecl_realloc(void *ptr, cl_index o, cl_index n); @@ -267,6 +220,30 @@ extern ECL_API void ecl_free(void *ptr); extern ECL_API void ecl_copy(void *dst, void *src, cl_index ndx); #define ecl_free_unsafe(x) ecl_free(x); +/* boot.c */ +extern ECL_API int ecl_boot(void); +extern ECL_API int ecl_halt(void); + +extern ECL_API const cl_object ecl_ct_Jan1st1970UT; +extern ECL_API const cl_object ecl_ct_null_string; + +extern ECL_API const cl_object ecl_ct_default_rehash_size; +extern ECL_API const cl_object ecl_ct_default_rehash_threshold; + +extern ECL_API const cl_object ecl_ct_singlefloat_zero; +extern ECL_API const cl_object ecl_ct_doublefloat_zero; +extern ECL_API const cl_object ecl_ct_longfloat_zero; + +extern ECL_API const cl_object ecl_ct_singlefloat_minus_zero; +extern ECL_API const cl_object ecl_ct_doublefloat_minus_zero; +extern ECL_API const cl_object ecl_ct_longfloat_minus_zero; + +extern ECL_API const cl_object ecl_ct_plus_half; +extern ECL_API const cl_object ecl_ct_minus_half; + +extern ECL_API const cl_object ecl_ct_protect_tag; +extern ECL_API const cl_object ecl_ct_dummy_tag; + /* alloc.c / alloc_2.c */ extern ECL_API cl_object ecl_alloc_object(cl_type t); @@ -310,6 +287,7 @@ typedef union { } cl_symbol_initializer; extern ECL_API cl_symbol_initializer cl_symbols[]; extern ECL_API cl_index cl_num_symbols_in_core; +extern ECL_API struct ecl_symbol ecl_symbols[]; #define ECL_SYM(name,code) ((cl_object)(cl_symbols+(code))) @@ -318,6 +296,11 @@ extern ECL_API cl_index cl_num_symbols_in_core; extern ECL_API cl_object APPLY_fixed(cl_narg n, cl_object (*f)(), cl_object *x); extern ECL_API cl_object APPLY(cl_narg n, cl_objectfn, cl_object *x); +/* stack.c */ +extern ECL_API cl_object ecl_make_stack(cl_index dim); +extern ECL_API cl_object ecl_stack_push(cl_object stack, cl_object elt); +extern ECL_API cl_object ecl_stack_del(cl_object stack, cl_object elt); +extern ECL_API cl_object ecl_stack_popu(cl_object stack); /* array.c */ @@ -539,12 +522,10 @@ extern ECL_API cl_object ecl_stack_frame_pop_values(cl_object f); extern ECL_API void ecl_stack_frame_close(cl_object f); #define si_apply_from_stack_frame ecl_apply_from_stack_frame -extern ECL_API void FEstack_underflow(void) ecl_attr_noreturn; -extern ECL_API void FEstack_advance(void) ecl_attr_noreturn; -extern ECL_API cl_object *ecl_stack_grow(cl_env_ptr env); -extern ECL_API cl_object *ecl_stack_set_size(cl_env_ptr env, cl_index new_size); -extern ECL_API cl_index ecl_stack_push_values(cl_env_ptr env); -extern ECL_API void ecl_stack_pop_values(cl_env_ptr env, cl_index n); +extern ECL_API cl_object *ecl_vms_extend(cl_env_ptr env); +extern ECL_API cl_object *ecl_vms_set_size(cl_env_ptr env, cl_index new_size); +extern ECL_API cl_index ecl_vms_push_values(cl_env_ptr env); +extern ECL_API void ecl_vms_pop_values(cl_env_ptr env, cl_index n); extern ECL_API cl_object ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes); extern ECL_API cl_object _ecl_bytecodes_dispatch(cl_narg narg, ...); extern ECL_API cl_object _ecl_bclosure_dispatch(cl_narg narg, ...); @@ -560,6 +541,8 @@ extern ECL_API cl_object si_bc_join(cl_object lex, cl_object code, cl_object dat extern ECL_API cl_object cl_error _ECL_ARGS((cl_narg narg, cl_object eformat, ...)) ecl_attr_noreturn; extern ECL_API cl_object cl_cerror _ECL_ARGS((cl_narg narg, cl_object cformat, cl_object eformat, ...)); +extern ECL_API cl_object ecl_exception_handler(cl_object exception); + extern ECL_API void ecl_internal_error(const char *s) ecl_attr_noreturn; #ifdef ECL_THREADS extern ECL_API void ecl_thread_internal_error(const char *s) ecl_attr_noreturn; @@ -567,6 +550,8 @@ extern ECL_API void ecl_thread_internal_error(const char *s) ecl_attr_noreturn; extern ECL_API void ecl_unrecoverable_error(cl_env_ptr the_env, const char *message) ecl_attr_noreturn; extern ECL_API void ecl_miscompilation_error(void) ecl_attr_noreturn; extern ECL_API void ecl_cs_overflow(void) /*ecl_attr_noreturn*/; + +extern ECL_API void CEstack_overflow(cl_object resume, cl_object type, cl_object size); extern ECL_API void FEprogram_error(const char *s, int narg, ...) ecl_attr_noreturn; extern ECL_API void FEcontrol_error(const char *s, int narg, ...) ecl_attr_noreturn; extern ECL_API void FEreader_error(const char *s, cl_object stream, int narg, ...) ecl_attr_noreturn; @@ -596,6 +581,7 @@ extern ECL_API void FEtimeout() ecl_attr_noreturn; extern ECL_API void FEerror_not_owned(cl_object lock) ecl_attr_noreturn; extern ECL_API void FEunknown_lock_error(cl_object lock) ecl_attr_noreturn; extern ECL_API cl_object CEerror(cl_object c, const char *err_str, int narg, ...); +extern ECL_API void CEstack_overflow(cl_object type, cl_object limit, cl_object resume); extern ECL_API void FElibc_error(const char *msg, int narg, ...) ecl_attr_noreturn; #if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) extern ECL_API void FEwin32_error(const char *msg, int narg, ...) ecl_attr_noreturn; @@ -991,7 +977,7 @@ typedef enum { } ecl_option; extern ECL_API const char *ecl_self; -extern ECL_API void ecl_set_option(int option, cl_fixnum value); +extern ECL_API cl_fixnum ecl_set_option(int option, cl_fixnum value); extern ECL_API cl_fixnum ecl_get_option(int option); extern ECL_API int cl_boot(int argc, char **argv); extern ECL_API void cl_shutdown(void); @@ -1642,12 +1628,11 @@ extern ECL_API cl_object si_bds_var(cl_object arg); extern ECL_API cl_object si_bds_val(cl_object arg); extern ECL_API cl_object si_sch_frs_base(cl_object fr, cl_object ihs); extern ECL_API cl_object si_reset_stack_limits(void); -extern ECL_API cl_object si_reset_margin(cl_object type); extern ECL_API cl_object si_set_limit(cl_object type, cl_object size); extern ECL_API cl_object si_get_limit(cl_object type); extern ECL_API cl_index ecl_progv(cl_env_ptr env, cl_object vars, cl_object values); -extern ECL_API void ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_top_index); +extern ECL_API void ecl_bds_unwind(cl_env_ptr env, cl_index new_bds_ndx); extern ECL_API void ecl_unwind(cl_env_ptr env, struct ecl_frame *fr) ecl_attr_noreturn; extern ECL_API struct ecl_frame *frs_sch(cl_object frame_id); @@ -1837,12 +1822,13 @@ extern ECL_API cl_object mp_mailbox_try_read(cl_object mailbox); extern ECL_API cl_object mp_mailbox_send(cl_object mailbox, cl_object msg); extern ECL_API cl_object mp_mailbox_try_send(cl_object mailbox, cl_object msg); -/* threads/atomic.c */ +/* nucleus/atomic.c */ extern ECL_API cl_object ecl_atomic_get(cl_object *slot); -extern ECL_API void ecl_atomic_push(cl_object *slot, cl_object o); +extern ECL_API cl_object ecl_atomic_psh(cl_object *slot, cl_object cons); extern ECL_API cl_object ecl_atomic_pop(cl_object *slot); extern ECL_API cl_index ecl_atomic_index_incf(cl_index *slot); +#define ecl_atomic_push(slot, obj) ecl_atomic_psh(slot, ecl_list1(obj)); /* threads/mutex.c */ @@ -1871,6 +1857,19 @@ extern ECL_API cl_object ecl_make_rwlock(cl_object lock); #endif /* ECL_THREADS */ +/* nucleus/module.c */ + +extern ECL_API cl_object ecl_add_module(cl_object self); +extern ECL_API cl_object ecl_del_module(cl_object self); +extern ECL_API cl_object ecl_modules_init_env(cl_env_ptr the_env); +extern ECL_API cl_object ecl_modules_free_env(cl_env_ptr the_env); +extern ECL_API cl_object ecl_modules_init_cpu(cl_env_ptr the_env); +extern ECL_API cl_object ecl_modules_free_cpu(cl_env_ptr the_env); + +extern ECL_API cl_object ecl_module_no_op_env(cl_env_ptr the_env); +extern ECL_API cl_object ecl_module_no_op_cpu(cl_env_ptr the_env); +extern ECL_API cl_object ecl_module_no_op(); + /* time.c */ extern ECL_API cl_object cl_sleep(cl_object z); diff --git a/src/h/internal.h b/src/h/internal.h index 296f7520b818b0120a05932b0d0ffe394d51d75a..bcd02764068532e824ec049ec89035c02ea233da 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -23,34 +23,39 @@ extern "C" { #define unlikely_if(x) if (ecl_unlikely(x)) /* booting */ +extern ECL_API cl_object ecl_module_process; +extern ECL_API cl_object ecl_module_stacks; +extern ECL_API cl_object ecl_module_dummy; +extern ECL_API cl_object ecl_module_gc; +extern ECL_API cl_object ecl_module_unixint; +#ifdef ECL_THREADS +extern ECL_API cl_object ecl_module_thread; +#endif +extern ECL_API cl_object ecl_module_bignum; +extern ECL_API cl_object ecl_module_ffi; +extern ECL_API cl_object ecl_module_aux; + extern void init_all_symbols(void); -extern void init_alloc(int pass); extern void init_backq(void); extern void init_big(); extern void init_clos(void); extern void init_error(void); extern void init_eval(void); extern void init_file(void); -#ifndef GBC_BOEHM -extern void init_GC(void); -#endif +extern void init_gc(void); extern void init_macros(void); extern void init_read(void); -extern void init_stacks(cl_env_ptr); -extern void init_unixint(int pass); extern void init_unixtime(void); extern void init_compiler(void); extern void init_process(void); -#ifdef ECL_THREADS -extern void init_threads(void); -#endif +extern void init_modules(void); extern void ecl_init_env(cl_env_ptr); extern void init_lib_LSP(cl_object); extern cl_env_ptr _ecl_alloc_env(cl_env_ptr parent); extern void _ecl_dealloc_env(cl_env_ptr); -/* alloc.d/alloc_2.d */ +/* mem_gc.d */ #ifdef GBC_BOEHM #define ECL_COMPACT_OBJECT_EXTRA(x) ((void*)((x)->array.displaced)) @@ -298,9 +303,6 @@ struct cl_compiler_ref { extern void _ecl_unexpected_return() ecl_attr_noreturn; extern cl_object _ecl_strerror(int code); -extern ECL_API cl_object si_serror _ECL_ARGS -((cl_narg narg, cl_object cformat, cl_object eformat, ...)); - /* eval.d */ @@ -482,8 +484,8 @@ extern cl_object _ecl_long_double_to_integer(long double d); extern cl_fixnum ecl_option_values[ECL_OPT_LIMIT+1]; -extern void ecl_init_bignum_registers(cl_env_ptr env); -extern void ecl_clear_bignum_registers(cl_env_ptr env); +extern cl_object ecl_init_bignum_registers(cl_env_ptr env); +extern cl_object ecl_free_bignum_registers(cl_env_ptr env); /* threads/mutex.d */ @@ -552,12 +554,16 @@ extern cl_object ecl_deserialize(uint8_t *data); /* stacks.d */ #define CL_NEWENV_BEGIN {\ const cl_env_ptr the_env = ecl_process_env(); \ - cl_index __i = ecl_stack_push_values(the_env); \ + cl_index __i = ecl_vms_push_values(the_env); \ #define CL_NEWENV_END \ - ecl_stack_pop_values(the_env,__i); } + ecl_vms_pop_values(the_env,__i); } -extern void ecl_cs_set_org(cl_env_ptr env); +extern void ecl_cs_init(cl_env_ptr env); +extern void ecl_frs_set_limit(cl_env_ptr env, cl_index n); +extern void ecl_bds_set_limit(cl_env_ptr env, cl_index n); +extern void ecl_vms_set_limit(cl_env_ptr env, cl_index n); +extern void ecl_cs_set_size(cl_env_ptr env, cl_index n); #ifndef RLIM_SAVED_MAX # define RLIM_SAVED_MAX RLIM_INFINITY @@ -572,13 +578,6 @@ extern void ecl_cs_set_org(cl_env_ptr env); #ifdef ECL_THREADS extern ECL_API cl_object mp_suspend_loop(); extern ECL_API cl_object mp_break_suspend_loop(); - -# ifdef ECL_WINDOWS_THREADS -# define ecl_thread_exit() ExitThread(0); -# else -# define ecl_thread_exit() pthread_exit(NULL); -# endif /* ECL_WINDOWS_THREADS */ - #endif /* time.d */ @@ -592,7 +591,7 @@ extern void ecl_get_internal_real_time(struct ecl_timeval *time); extern void ecl_get_internal_run_time(struct ecl_timeval *time); extern void ecl_musleep(double time); -#define UTC_time_to_universal_time(x) ecl_plus(ecl_make_integer(x),cl_core.Jan1st1970UT) +#define UTC_time_to_universal_time(x) ecl_plus(ecl_make_integer(x),ecl_ct_Jan1st1970UT) extern cl_fixnum ecl_runtime(void); /* unixfsys.d */ @@ -748,9 +747,30 @@ extern void ecl_interrupt_process(cl_object process, cl_object function); #include +/* sigmask */ + +#ifdef HAVE_SIGPROCMASK +# include +# ifdef ECL_THREADS +static inline int +ecl_sigmask(int how, const sigset_t *set, sigset_t *oldset) +{ + return pthread_sigmask(how, set, oldset); +} +# else +static inline int +ecl_sigmask(int how, const sigset_t *set, sigset_t *oldset) +{ + return sigprocmask(how, set, oldset); +} +# endif +#endif + +/* global locks */ + #ifdef ECL_THREADS -# define ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) \ - ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &cl_core.global_lock) +# define ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) \ + ECL_WITH_NATIVE_LOCK_BEGIN(the_env, &ecl_core.global_lock) # define ECL_WITH_GLOBAL_LOCK_END \ ECL_WITH_NATIVE_LOCK_END # define ECL_WITH_LOCK_BEGIN(the_env,lock) { \ @@ -775,21 +795,21 @@ extern void ecl_interrupt_process(cl_object process, cl_object function); ECL_UNWIND_PROTECT_THREAD_SAFE_EXIT { \ ecl_mutex_unlock(__ecl_the_lock); \ } ECL_UNWIND_PROTECT_THREAD_SAFE_END; } -# define ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(the_env) { \ - const cl_env_ptr __ecl_pack_env = the_env; \ +# define ECL_WITH_GLOBAL_ENV_RDLOCK_BEGIN(the_env) { \ + const cl_env_ptr __ecl_pack_env = the_env; \ ecl_bds_bind(__ecl_pack_env, ECL_INTERRUPTS_ENABLED, ECL_NIL); \ - ecl_rwlock_lock_read(&cl_core.global_env_lock); -# define ECL_WITH_GLOBAL_ENV_RDLOCK_END \ - ecl_rwlock_unlock_read(&cl_core.global_env_lock); \ - ecl_bds_unwind1(__ecl_pack_env); \ + ecl_rwlock_lock_read(&ecl_core.global_env_lock); +# define ECL_WITH_GLOBAL_ENV_RDLOCK_END \ + ecl_rwlock_unlock_read(&ecl_core.global_env_lock); \ + ecl_bds_unwind1(__ecl_pack_env); \ ecl_check_pending_interrupts(__ecl_pack_env); } # define ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(the_env) { \ const cl_env_ptr __ecl_pack_env = the_env; \ ecl_bds_bind(__ecl_pack_env, ECL_INTERRUPTS_ENABLED, ECL_NIL); \ - ecl_rwlock_lock_write(&cl_core.global_env_lock); -# define ECL_WITH_GLOBAL_ENV_WRLOCK_END \ - ecl_rwlock_unlock_write(&cl_core.global_env_lock); \ - ecl_bds_unwind1(__ecl_pack_env); \ + ecl_rwlock_lock_write(&ecl_core.global_env_lock); +# define ECL_WITH_GLOBAL_ENV_WRLOCK_END \ + ecl_rwlock_unlock_write(&ecl_core.global_env_lock); \ + ecl_bds_unwind1(__ecl_pack_env); \ ecl_check_pending_interrupts(__ecl_pack_env); } #else # define ECL_WITH_GLOBAL_LOCK_BEGIN(the_env) diff --git a/src/h/nucleus.h b/src/h/nucleus.h new file mode 100644 index 0000000000000000000000000000000000000000..1072e4be6ad6627c59f805cbb28cd3cacdaad3c7 --- /dev/null +++ b/src/h/nucleus.h @@ -0,0 +1,65 @@ +/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */ +/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */ + +#ifndef ECL_NUCLEUS_H +#define ECL_NUCLEUS_H + +#include "external.h" + +struct ecl_core_struct { + cl_env_ptr first_env; +#ifdef ECL_THREADS + cl_object threads; + ecl_mutex_t processes_lock; + ecl_mutex_t global_lock; + ecl_mutex_t error_lock; + ecl_rwlock_t global_env_lock; + cl_index last_var_index; + cl_object reused_indices; +#endif + size_t max_heap_size; + cl_object bytes_consed; + cl_object gc_counter; + bool gc_stats; + char *safety_region; + + cl_index default_sigmask_bytes; + cl_object known_signals; + + int path_max; + cl_object pathname_translations; + + cl_object modules; + cl_object libraries; + cl_object library_pathname; +}; + +/* process.c */ +cl_env_ptr ecl_adopt_cpu(); +cl_env_ptr ecl_spawn_cpu(); +void ecl_disown_cpu(); + +/* control.c */ +void ecl_escape(cl_object continuation) ecl_attr_noreturn; +cl_object ecl_signal(cl_object condition, cl_object returns, cl_object thread); +cl_object ecl_call_with_handler(cl_object handler, cl_object continuation); + +/* Binding a handler conses a new list, but at this stage we don't assume the + the garbage collector to work! Luckily the extent of the binding is dynamic + and we can allocate cons on the stack. */ +#define ECL_WITH_HANDLER_BEGIN(the_env, handler) do { \ + const cl_env_ptr __the_env = the_env; \ + cl_object __ecl_sym = ECL_SIGNAL_HANDLERS; \ + cl_object __ecl_hnd = ECL_SYM_VAL(__the_env, __ecl_sym); \ + cl_object __ecl_hnds = ecl_cons_stack(handler, __ecl_hnd); \ + ecl_bds_bind(__the_env, __ecl_sym, __ecl_hnds); + +#define ECL_WITH_HANDLER_END ecl_bds_unwind1(__the_env); } while(0) + +cl_object ecl_raise(ecl_ex_type t, bool ret, + cl_object a1, cl_object a2, cl_object a3, void *a4); + +cl_object ecl_ferror(ecl_ex_type extype, cl_object type, cl_object args); +cl_object ecl_cerror(ecl_ex_type extype, cl_object type, cl_object args); + +#endif /* ECL_NUCLEUS_H */ diff --git a/src/h/object.h b/src/h/object.h index e0ee2fb348e54bf78cddf964eca659cc255d782b..f29fe449f3e626c3c9b404109d3e86fe20f22c4e 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -84,6 +84,8 @@ typedef enum { t_codeblock, t_foreign, t_frame, + t_exception, + t_module, t_weak_pointer, #ifdef ECL_SSE2 t_sse_pack, @@ -99,10 +101,12 @@ typedef enum { Definition of the type of LISP objects. */ typedef union cl_lispunion *cl_object; +typedef struct cl_env_struct *cl_env_ptr; typedef cl_object cl_return; typedef cl_fixnum cl_narg; typedef cl_object (*cl_objectfn)(cl_narg narg, ...); typedef cl_object (*cl_objectfn_fixed)(); +typedef cl_object (*cl_objectfn_envfn)(cl_env_ptr); /* OBJect NULL value. @@ -258,16 +262,20 @@ enum ecl_stype { /* symbol type */ }; #define ECL_NIL ((cl_object)t_list) -#define ECL_NIL_SYMBOL ((cl_object)cl_symbols) -#define ECL_T ((cl_object)(cl_symbols+1)) -#define ECL_UNBOUND ((cl_object)(cl_symbols+2)) -#define ECL_PROTECT_TAG ((cl_object)(cl_symbols+3)) -#define ECL_DUMMY_TAG ((cl_object)(cl_symbols+4)) -#define ECL_RESTART_CLUSTERS ((cl_object)(cl_symbols+5)) -#define ECL_HANDLER_CLUSTERS ((cl_object)(cl_symbols+6)) -#define ECL_INTERRUPTS_ENABLED ((cl_object)(cl_symbols+7)) #define ECL_NO_TL_BINDING ((cl_object)(1 << ECL_TAG_BITS)) +#define ECL_PROTECT_TAG ecl_ct_protect_tag +#define ECL_DUMMY_TAG ecl_ct_dummy_tag + +#define ECL_SIGNAL_HANDLERS ((cl_object)(ecl_symbols+0)) +#define ECL_RESTART_CLUSTERS ((cl_object)(ecl_symbols+1)) +#define ECL_INTERRUPTS_ENABLED ((cl_object)(ecl_symbols+2)) +#define ECL_ALLOW_OTHER_KEYS ((cl_object)(ecl_symbols+3)) +#define ECL_T ((cl_object)(ecl_symbols+4)) +#define ECL_UNBOUND ((cl_object)(ecl_symbols+5)) + +#define ECL_NIL_SYMBOL ((cl_object)(cl_symbols+0)) + struct ecl_symbol { _ECL_HDR1(stype); /* symbol type */ cl_object value; /* global value of the symbol */ @@ -932,6 +940,56 @@ struct ecl_stack_frame { struct cl_env_struct *env; }; +typedef enum { + ECL_EX_FERROR, /* general purpose fatal error */ + ECL_EX_CERROR, /* general purpose continuable error */ + ECL_EX_CS_OVR, /* stack overflow */ + ECL_EX_FRS_OVR, /* stack overflow */ + ECL_EX_BDS_OVR, /* stack overflow */ + /* Kludges for the bytecodes VM */ + ECL_EX_VM_BADARG_EXCD, + ECL_EX_VM_BADARG_UNKK, + ECL_EX_VM_BADARG_ODDK, + ECL_EX_VM_BADARG_NTH_VAL, + ECL_EX_VM_BADARG_ENDP, + ECL_EX_VM_BADARG_CAR, + ECL_EX_VM_BADARG_CDR, + ECL_EX_VM_BADARG_PROGV, + /* Specific normal conditions */ + ECL_EX_V_CSETQ, /* assigning a constant */ + ECL_EX_V_CBIND, /* binding a constant */ + ECL_EX_V_UNBND, /* unbound variable */ + ECL_EX_V_BNAME, /* illegal variable name */ + ECL_EX_F_NARGS, /* wrong number of arguments */ + ECL_EX_F_UNDEF, /* undefined function */ + ECL_EX_F_INVAL, /* non-function passed as function */ + ECL_EX_S_FMISS /* missing unwind frame (ecl_escape) */ +} ecl_ex_type; + +#define ECL_EXCEPTIONP(x) ((ECL_IMMEDIATE(x)==0) && ((x)->d.t==t_exception)) + +struct ecl_exception { + _ECL_HDR1(ex_type); + /* Slots for storing contextual data. Depends on the exception type. */ + cl_object arg1; /* usually the offending object or the type. */ + cl_object arg2; /* usually additional arguments or the flag. */ + cl_object arg3; /* arbitrary lisp extra argument (i.e ECL_NIL). */ + void * arg4; /* arbitrary last ditch argument (usually NULL). */ +}; + +struct ecl_module { + _ECL_HDR; + cl_object name; + cl_objectfn_fixed create; + cl_objectfn_fixed enable; + cl_objectfn_envfn init_env; + cl_objectfn_envfn init_cpu; + cl_objectfn_envfn free_cpu; + cl_objectfn_envfn free_env; + cl_objectfn_fixed disable; + cl_objectfn_fixed destroy; +}; + struct ecl_weak_pointer { /* weak pointer to value */ _ECL_HDR; cl_object value; @@ -985,19 +1043,16 @@ enum { struct ecl_process { _ECL_HDR; cl_object name; + cl_object exit_values; + cl_objectfn entry; /* entry address (matches ecl_cfun offset) */ cl_object function; cl_object args; - struct cl_env_struct *env; - cl_object interrupt; - cl_object initial_bindings; - cl_object parent; - cl_object exit_values; + cl_object inherit_bindings_p; cl_object woken_up; ecl_mutex_t start_stop_lock; /* phase is updated only when we hold this lock */ ecl_cond_var_t exit_barrier; /* process-join waits on this barrier */ cl_index phase; - ecl_thread_t thread; - int trap_fpe_bits; + struct cl_env_struct *env; }; enum { @@ -1160,6 +1215,8 @@ union cl_lispunion { struct ecl_cclosure cclosure; /* compiled closure */ struct ecl_dummy d; /* dummy */ struct ecl_instance instance; /* clos instance */ + struct ecl_exception exception; /* exception */ + struct ecl_module module; /* core module */ #ifdef ECL_THREADS struct ecl_process process; /* process */ struct ecl_lock lock; /* lock */ diff --git a/src/h/stack-resize.h b/src/h/stack-resize.h index 93e9ee6bbc29b8e931fdb08f4be18293ece53c20..09e67df353b8068ec1e62fed7084e77d9c94dfeb 100644 --- a/src/h/stack-resize.h +++ b/src/h/stack-resize.h @@ -14,11 +14,10 @@ #ifndef ECL_STACK_RESIZE_H #define ECL_STACK_RESIZE_H -/* We can't block interrupts with ecl_disable_interrupts() and write - * in the thread local environment if we use fast interrupt dispatch - * via mprotect(), so we have to use sigprocmask instead. No - * performance problems, since this is only used for stack - * resizing. */ +/* We can't block interrupts with ecl_disable_interrupts() and write in the + * thread local environment if we use fast interrupt dispatch via mprotect(), so + * we have to use sigprocmask instead. No performance problems, since this is + * only used for stack resizing. */ #if defined(ECL_THREADS) && defined(ECL_USE_MPROTECT) # ifdef HAVE_SIGPROCMASK # include diff --git a/src/h/stacks.h b/src/h/stacks.h index 1c38c41c382db361c0c74e9ee7138dedb1f1a85c..8d76623a236a2d0d75d544d920ae36a61d5948bc 100755 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -27,10 +27,10 @@ extern "C" { #ifdef ECL_DOWN_STACK #define ecl_cs_check(env,var) \ - if (ecl_unlikely((char*)(&var) <= (env)->cs_limit)) ecl_cs_overflow() + if (ecl_unlikely((char*)(&var) <= (env)->c_stack.limit)) ecl_cs_overflow() #else #define ecl_cs_check(env,var) \ - if (ecl_unlikely((char*)(&var) >= (env)->cs_limit)) ecl_cs_overflow() + if (ecl_unlikely((char*)(&var) >= (env)->c_stack.limit)) ecl_cs_overflow() #endif /********************************************************* @@ -78,7 +78,7 @@ typedef struct ecl_bds_frame { } *ecl_bds_ptr; #define ecl_bds_check(env) \ - (ecl_unlikely(env->bds_top >= env->bds_limit)? (ecl_bds_overflow(),1) : 0) + (ecl_unlikely(env->bds_stack.top >= env->bds_stack.limit)? (ecl_bds_overflow(),1) : 0) #define ECL_MISSING_SPECIAL_BINDING (~((cl_index)0)) @@ -100,25 +100,25 @@ extern ECL_API cl_object ecl_bds_set(cl_env_ptr env, cl_object s, cl_object v); # define ECL_SETQ(env,s,v) ((s)->symbol.value=(v)) #endif -#ifdef __GNUC__ -static inline void ecl_bds_bind_inl(cl_env_ptr env, cl_object s, cl_object v) +#ifdef ECL_THREADS +static inline void +ecl_bds_bind_inl(cl_env_ptr env, cl_object s, cl_object v) { ecl_bds_ptr slot; -# ifdef ECL_THREADS cl_object *location; const cl_index index = s->symbol.binding; - if (index >= env->thread_local_bindings_size) { + if (index >= env->bds_stack.tl_bindings_size) { ecl_bds_bind(env,s,v); } else { - location = env->thread_local_bindings + index; - slot = env->bds_top+1; - if (slot >= env->bds_limit) slot = ecl_bds_overflow(); + location = env->bds_stack.tl_bindings + index; + slot = env->bds_stack.top+1; + if (slot >= env->bds_stack.limit) slot = ecl_bds_overflow(); /* First, we push a dummy symbol in the stack to * prevent segfaults when we are interrupted with a * call to ecl_bds_unwind. */ slot->symbol = ECL_DUMMY_TAG; AO_nop_full(); - ++env->bds_top; + ++env->bds_stack.top; /* Then we disable interrupts to ensure that * ecl_bds_unwind doesn't overwrite the symbol with * some random value. */ @@ -128,115 +128,102 @@ static inline void ecl_bds_bind_inl(cl_env_ptr env, cl_object s, cl_object v) *location = v; ecl_enable_interrupts_env(env); } -# else - slot = ++env->bds_top; - if (slot >= env->bds_limit) slot = ecl_bds_overflow(); - ecl_disable_interrupts_env(env); - slot->symbol = s; - slot->value = s->symbol.value; - s->symbol.value = v; - ecl_enable_interrupts_env(env); -# endif /* !ECL_THREADS */ } -static inline void ecl_bds_push_inl(cl_env_ptr env, cl_object s) +static inline void +ecl_bds_push_inl(cl_env_ptr env, cl_object s) { ecl_bds_ptr slot; -# ifdef ECL_THREADS cl_object *location; const cl_index index = s->symbol.binding; - if (index >= env->thread_local_bindings_size) { + if (index >= env->bds_stack.tl_bindings_size) { ecl_bds_push(env, s); } else { - location = env->thread_local_bindings + index; - slot = env->bds_top+1; - if (slot >= env->bds_limit) slot = ecl_bds_overflow(); + location = env->bds_stack.tl_bindings + index; + slot = env->bds_stack.top+1; + if (slot >= env->bds_stack.limit) slot = ecl_bds_overflow(); slot->symbol = ECL_DUMMY_TAG; AO_nop_full(); - ++env->bds_top; + ++env->bds_stack.top; ecl_disable_interrupts_env(env); slot->symbol = s; slot->value = *location; if (*location == ECL_NO_TL_BINDING) *location = s->symbol.value; ecl_enable_interrupts_env(env); } -# else - slot = ++env->bds_top; - if (slot >= env->bds_limit) slot = ecl_bds_overflow(); - ecl_disable_interrupts_env(env); - slot->symbol = s; - slot->value = s->symbol.value; - ecl_enable_interrupts_env(env); -# endif /* !ECL_THREADS */ } -static inline void ecl_bds_unwind1_inl(cl_env_ptr env) +static inline void +ecl_bds_unwind1_inl(cl_env_ptr env) { - cl_object s = env->bds_top->symbol; -# ifdef ECL_THREADS - cl_object *location = env->thread_local_bindings + s->symbol.binding; - *location = env->bds_top->value; -# else - s->symbol.value = env->bds_top->value; -# endif - --env->bds_top; + cl_object s = env->bds_stack.top->symbol; + cl_object *location = env->bds_stack.tl_bindings + s->symbol.binding; + *location = env->bds_stack.top->value; + --env->bds_stack.top; } -# ifdef ECL_THREADS -static inline cl_object ecl_bds_read_inl(cl_env_ptr env, cl_object s) +static inline cl_object +ecl_bds_read_inl(cl_env_ptr env, cl_object s) { cl_index index = s->symbol.binding; - if (index < env->thread_local_bindings_size) { - cl_object x = env->thread_local_bindings[index]; + if (index < env->bds_stack.tl_bindings_size) { + cl_object x = env->bds_stack.tl_bindings[index]; if (x != ECL_NO_TL_BINDING) return x; } return s->symbol.value; } -static inline cl_object *ecl_bds_ref_inl(cl_env_ptr env, cl_object s) +static inline cl_object * +ecl_bds_ref_inl(cl_env_ptr env, cl_object s) { cl_index index = s->symbol.binding; - if (index < env->thread_local_bindings_size) { - cl_object *location = env->thread_local_bindings + index; + if (index < env->bds_stack.tl_bindings_size) { + cl_object *location = env->bds_stack.tl_bindings + index; if (*location != ECL_NO_TL_BINDING) return location; } return &s->symbol.value; } -# define ecl_bds_set(env,s,v) (*ecl_bds_ref_inl(env,s)=(v)) -# define ecl_bds_read ecl_bds_read_inl -# endif -# define ecl_bds_bind ecl_bds_bind_inl -# define ecl_bds_push ecl_bds_push_inl -# define ecl_bds_unwind1 ecl_bds_unwind1_inl -#else /* !__GNUC__ */ -# ifndef ECL_THREADS -# define ecl_bds_bind(env,sym,val) do { \ - const cl_env_ptr env_copy = (env); \ - const cl_object s = (sym); \ - const cl_object v = (val); \ - ecl_bds_check(env_copy); \ - ecl_bds_ptr slot = ++(env_copy->bds_top); \ - ecl_disable_interrupts_env(env_copy); \ - slot->symbol = s; \ - slot->value = s->symbol.value; \ - s->symbol.value = v; \ - ecl_enable_interrupts_env(env_copy); } while (0) -# define ecl_bds_push(env,sym) do { \ - const cl_env_ptr env_copy = (env); \ - const cl_object s = (sym); \ - const cl_object v = s->symbol.value; \ - ecl_bds_check(env_copy); \ - ecl_bds_ptr slot = ++(env_copy->bds_top); \ - ecl_disable_interrupts_env(env_copy); \ - slot->symbol = s; \ - slot->value = s->symbol.value; \ - ecl_enable_interrupts_env(env_copy); } while (0); -# define ecl_bds_unwind1(env) do { \ - const cl_env_ptr env_copy = (env); \ - const cl_object s = env_copy->bds_top->symbol; \ - s->symbol.value = env_copy->bds_top->value; \ - --(env_copy->bds_top); } while (0) -# endif /* !ECL_THREADS */ -#endif /* !__GNUC__ */ + +# define ecl_bds_set(env,s,v) (*ecl_bds_ref_inl(env,s)=(v)) +# define ecl_bds_read ecl_bds_read_inl + +#else /* ECL_THREADS */ +static inline void +ecl_bds_bind_inl(cl_env_ptr env, cl_object s, cl_object v) +{ + ecl_bds_ptr slot; + slot = ++env->bds_stack.top; + if (slot >= env->bds_stack.limit) slot = ecl_bds_overflow(); + ecl_disable_interrupts_env(env); + slot->symbol = s; + slot->value = s->symbol.value; + s->symbol.value = v; + ecl_enable_interrupts_env(env); +} + +static inline void +ecl_bds_push_inl(cl_env_ptr env, cl_object s) +{ + ecl_bds_ptr slot; + slot = ++env->bds_stack.top; + if (slot >= env->bds_stack.limit) slot = ecl_bds_overflow(); + ecl_disable_interrupts_env(env); + slot->symbol = s; + slot->value = s->symbol.value; + ecl_enable_interrupts_env(env); +} + +static inline void +ecl_bds_unwind1_inl(cl_env_ptr env) +{ + cl_object s = env->bds_stack.top->symbol; + s->symbol.value = env->bds_stack.top->value; + --env->bds_stack.top; +} +#endif /* ECL_THREADS */ + +#define ecl_bds_bind ecl_bds_bind_inl +#define ecl_bds_push ecl_bds_push_inl +#define ecl_bds_unwind1 ecl_bds_unwind1_inl /**************************** * INVOCATION HISTORY STACK @@ -253,18 +240,18 @@ typedef struct ecl_ihs_frame { #define ecl_ihs_push(env,rec,fun,lisp_env) do { \ const cl_env_ptr __the_env = (env); \ ecl_ihs_ptr const r = (ecl_ihs_ptr const)(rec); \ - r->next=__the_env->ihs_top; \ - r->function=(fun); \ - r->lex_env=(lisp_env); \ - r->index=__the_env->ihs_top->index+1; \ - r->bds=__the_env->bds_top - __the_env->bds_org; \ - __the_env->ihs_top = r; \ + r->next=__the_env->ihs_stack.top; \ + r->function=(fun); \ + r->lex_env=(lisp_env); \ + r->index=__the_env->ihs_stack.top->index+1; \ + r->bds=__the_env->bds_stack.top - __the_env->bds_stack.org; \ + __the_env->ihs_stack.top = r; \ } while(0) #define ecl_ihs_pop(env) do { \ const cl_env_ptr __the_env = (env); \ - ecl_ihs_ptr r = __the_env->ihs_top; \ - if (r) __the_env->ihs_top = r->next; \ + ecl_ihs_ptr r = __the_env->ihs_stack.top; \ + if (r) __the_env->ihs_stack.top = r->next; \ } while(0) /*************** @@ -293,9 +280,9 @@ typedef struct ecl_ihs_frame { typedef struct ecl_frame { jmp_buf frs_jmpbuf; cl_object frs_val; - cl_index frs_bds_top_index; ecl_ihs_ptr frs_ihs; - cl_index frs_sp; + cl_index frs_bds_ndx; + cl_index frs_vms_ndx; } *ecl_frame_ptr; extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr); @@ -306,8 +293,8 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr); int __ecl_frs_push_result = ecl_setjmp(__frame->frs_jmpbuf); \ ecl_enable_interrupts_env(env) -#define ecl_frs_pop(env) ((env)->frs_top--) -#define ecl_frs_pop_n(env,n) ((env)->frs_top-=n) +#define ecl_frs_pop(env) ((env)->frs_stack.top--) +#define ecl_frs_pop_n(env,n) ((env)->frs_stack.top-=n) /******************* * ARGUMENTS STACK @@ -377,51 +364,61 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr); * LISP STACK *************/ -#define ECL_STACK_INDEX(env) ((env)->stack_top - (env)->stack) +#define ECL_VMS_REF(env,n) ((env)->run_stack.top[n]) -#define ECL_STACK_PUSH(the_env,o) do { \ - const cl_env_ptr __env = (the_env); \ - cl_object *__new_top = __env->stack_top; \ - if (ecl_unlikely(__new_top >= __env->stack_limit)) { \ - __new_top = ecl_stack_grow(__env); \ - } \ - __env->stack_top = __new_top+1; \ - *__new_top = (o); } while (0) +static inline void +ecl_vms_push(cl_env_ptr env, cl_object o) { + cl_object *new_top = env->run_stack.top; + if (ecl_unlikely(new_top >= env->run_stack.limit)) { + new_top = ecl_vms_extend(env); + } + env->run_stack.top = new_top+1; + *new_top = (o); +} -#define ECL_STACK_POP_UNSAFE(env) *(--((env)->stack_top)) +static inline void +ecl_vms_grow(cl_env_ptr env, cl_index n) { + cl_object *new_top = env->run_stack.top; + while (ecl_unlikely((env->run_stack.limit - new_top) <= n)) { + new_top = ecl_vms_extend(env); + } + env->run_stack.top = new_top + n; +} -#define ECL_STACK_REF(env,n) ((env)->stack_top[n]) +static inline cl_object +ecl_vms_popu(cl_env_ptr env) +{ + return *(--((env)->run_stack.top)); +} -#define ECL_STACK_SET_INDEX(the_env,ndx) do { \ - const cl_env_ptr __env = (the_env); \ - cl_object *__new_top = __env->stack + (ndx); \ - if (ecl_unlikely(__new_top > __env->stack_top)) \ - FEstack_advance(); \ - __env->stack_top = __new_top; } while (0) +static inline void +ecl_vms_drop(cl_env_ptr env, cl_index n) +{ + env->run_stack.top -= n; +} -#define ECL_STACK_POP_N(the_env,n) do { \ - const cl_env_ptr __env = (the_env); \ - cl_object *__new_top = __env->stack_top - (n); \ - if (ecl_unlikely(__new_top < __env->stack)) \ - FEstack_underflow(); \ - __env->stack_top = __new_top; } while (0) +static inline cl_index +ecl_vms_index(cl_env_ptr env) { + return (env)->run_stack.top - (env)->run_stack.org; +} -#define ECL_STACK_POP_N_UNSAFE(the_env,n) ((the_env)->stack_top -= (n)) +static inline void +ecl_vms_unwind(cl_env_ptr env, cl_index ndx) +{ + env->run_stack.top = env->run_stack.org + (ndx); +} -#define ECL_STACK_PUSH_N(the_env,n) do { \ - const cl_env_ptr __env = (the_env) ; \ - cl_index __aux = (n); \ - cl_object *__new_top = __env->stack_top; \ - while (ecl_unlikely((__env->stack_limit - __new_top) <= __aux)) { \ - __new_top = ecl_stack_grow(__env); \ - } \ - __env->stack_top = __new_top + __aux; } while (0) +#define ECL_STACK_INDEX(env) ((env)->run_stack.top - (env)->run_stack.org) -#define ECL_STACK_FRAME_REF(f,ndx) ((f)->frame.env->stack[(f)->frame.base+(ndx)]) -#define ECL_STACK_FRAME_SET(f,ndx,o) do { ECL_STACK_FRAME_REF(f,ndx) = (o); } while(0) +#define ECL_STACK_FRAME_REF(f,ndx) \ + ((f)->frame.env->run_stack.org[(f)->frame.base+(ndx)]) +#define ECL_STACK_FRAME_SET(f,ndx,o) \ + do { ECL_STACK_FRAME_REF(f,ndx) = (o); } while(0) -#define ECL_STACK_FRAME_PTR(f) ((f)->frame.env->stack+(f)->frame.base) -#define ECL_STACK_FRAME_TOP(f) ((f)->frame.env->stack+(f)->frame.sp) +#define ECL_STACK_FRAME_PTR(f) \ + ((f)->frame.env->run_stack.org+(f)->frame.base) +#define ECL_STACK_FRAME_TOP(f) \ + ((f)->frame.env->run_stack.org+(f)->frame.sp) #define ECL_STACK_FRAME_COPY(dest,orig) do { \ cl_object __dst = (dest); \ @@ -443,16 +440,16 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr); cl_index __nr; \ ecl_frs_push(__the_env,ECL_PROTECT_TAG); \ if (__ecl_frs_push_result) { \ - __unwinding=1; __next_fr=__the_env->nlj_fr; \ + __unwinding=1; __next_fr=__the_env->frs_stack.nlj_fr; \ } else { #define ECL_UNWIND_PROTECT_EXIT \ __unwinding=0; } \ ecl_frs_pop(__the_env); \ - __nr = ecl_stack_push_values(__the_env); + __nr = ecl_vms_push_values(__the_env); #define ECL_UNWIND_PROTECT_END \ - ecl_stack_pop_values(__the_env,__nr); \ + ecl_vms_pop_values(__the_env,__nr); \ if (__unwinding) ecl_unwind(__the_env,__next_fr); } while(0) /* unwind-protect variant which disables interrupts during cleanup */ @@ -460,15 +457,15 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr); __unwinding=0; } \ ecl_bds_bind(__the_env,ECL_INTERRUPTS_ENABLED,ECL_NIL); \ ecl_frs_pop(__the_env); \ - __nr = ecl_stack_push_values(__the_env); + __nr = ecl_vms_push_values(__the_env); #define ECL_UNWIND_PROTECT_THREAD_SAFE_END \ - ecl_stack_pop_values(__the_env,__nr); \ + ecl_vms_pop_values(__the_env,__nr); \ ecl_bds_unwind1(__the_env); \ ecl_check_pending_interrupts(__the_env); \ if (__unwinding) ecl_unwind(__the_env,__next_fr); } while(0) -#define ECL_NEW_FRAME_ID(env) ecl_make_fixnum(env->frame_id++) +#define ECL_NEW_FRAME_ID(env) ecl_make_fixnum(env->frs_stack.frame_id++) #define ECL_BLOCK_BEGIN(the_env,id) do { \ const cl_object __id = ECL_NEW_FRAME_ID(the_env); \ @@ -507,7 +504,7 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(cl_env_ptr); #define ECL_HANDLER_CASE_BEGIN(the_env, names) do { \ const cl_env_ptr __the_env = (the_env); \ const cl_object __ecl_tag = ecl_list1(names); \ - ecl_bds_bind(__the_env, ECL_HANDLER_CLUSTERS, \ + ecl_bds_bind(__the_env, ECL_SIGNAL_HANDLERS, \ si_bind_simple_handlers(__ecl_tag, names)); \ ecl_frs_push(__the_env,__ecl_tag); \ if (__ecl_frs_push_result == 0) { diff --git a/src/h/threads.h b/src/h/threads.h index 5571b228af4a8d3b646919cd8fb7ba8f1a22d6a1..eb4ff6755a38d6d5c75ecf9cfa9de5b96778c836 100644 --- a/src/h/threads.h +++ b/src/h/threads.h @@ -22,8 +22,8 @@ # endif #endif -#ifndef ECL_MUTEX_H -#define ECL_MUTEX_H +#ifndef ECL_THREADS_H +#define ECL_THREADS_H #include #ifdef ECL_WINDOWS_THREADS @@ -38,6 +38,45 @@ #endif #include +#ifdef ECL_WINDOWS_THREADS +/* Windows can't into typedefs in parameter lists. */ +/* typedef DWORD WINAPI (*ecl_thread_entry)(void *ptr); */ +static inline int +ecl_thread_create(cl_env_ptr the_env, /* ecl_thread_entry */ void* fun) +{ + HANDLE code; + DWORD threadId; + code = (HANDLE)CreateThread(NULL, 0, fun, the_env, 0, &threadId); + the_env->thread = code; + /* NULL handle is a failure. */ + return (code != NULL) ? 0 : 1; +} + +static inline void +ecl_thread_exit() +{ + ExitThread(0); +} +#else /* ECL_WINDOWS_THREADS */ +typedef void* (*ecl_thread_entry)(void *ptr); + +static inline int +ecl_thread_create(cl_env_ptr the_env, ecl_thread_entry fun) +{ + pthread_attr_t pthreadattr; + pthread_attr_init(&pthreadattr); + pthread_attr_setdetachstate(&pthreadattr, PTHREAD_CREATE_DETACHED); + return pthread_create(&the_env->thread, &pthreadattr, fun, the_env); +} + +static inline void +ecl_thread_exit() +{ + pthread_exit(NULL); +} +#endif /* ECL_WINDOWS_THREADS */ + + #if !defined(ECL_WINDOWS_THREADS) #define ECL_MUTEX_SUCCESS 0 @@ -734,6 +773,6 @@ ecl_rwlock_lock_write(ecl_rwlock_t *rwlock) #endif /* ECL_WINDOWS_THREADS */ -#endif /* ECL_MUTEX_H */ +#endif /* ECL_THREADS_H */ #endif /* ECL_THREADS */ diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index 32d7d3b5c161e0d8cac44641ad3456936598c678..6c23eb505ad78c7f42fe082e13d9f322a37cdd2d 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -192,7 +192,7 @@ ;;; Fixed: 10/10/2006 ;;; Description: ;;; -;;; Nested calls to queue_finalizer trashed the value of cl_core.to_be_finalized +;;; Nested calls to queue_finalizer trashed the value of ecl_core.to_be_finalized ;;; The following code tests that at least three objects are finalized. ;;; ;;; Note: this test fails in multithreaded mode. GC takes too long!