Commit 4eac7977 authored by jjgarcia's avatar jjgarcia

Preliminary support for POSIX threads.

parent 05bfc5d3
......@@ -1671,6 +1671,21 @@ ECL 0.9d
ABIs (i.e. applications may use 32-bit or 64-pointers, 32-bit or
64-registers, etc).
* System design: Multithreading
- Almost all data specific to ECL has migrated into two structures:
CL_ENV and CL_CORE. The first one contains stacks and other data
that is specific to a process. The second one contains data common
to the whole environment. CL_ENV is an actual variable in
single-threaded ECL, and a pointer to a thread-local structure in
a multi-threaded ECL.
- The implementation of thread-local dynamic bindings uses hash
tables to keep the value of the symbols.
- The actual implementation uses POSIX threads under Linux. Ports to
other operating systems are being worked out.
* Errors fixed:
- Bugs in the mechanism for automatically creating packages when
......@@ -1687,9 +1702,9 @@ ECL 0.9d
* Visible changes:
- New command line options -shell and -norc, which are useful for
scripting. New handling of command line options, is more robust
and allows combining the options -load, -eval, -shell in a number
of ways.
scripting. New and more robust handling of command line options,
permits combining (and repeating) the options -load, -eval, -shell
in a number of ways.
TODO:
=====
......
......@@ -55,7 +55,7 @@ ecl_min$(EXE): $(LIBRARIES) .gdbinit libecl.a
if [ -f CROSS-COMPILER ]; then \
touch $@; \
else \
$(CC) $(LDFLAGS) -o $@ c/cinit.o -L./ libecl.a -lgmp $(LIBRARIES) $(LIBS);\
$(CC) $(LDFLAGS) -o $@ c/cinit.o -L./ libecl.a -lgmp -lgc $(LIBS);\
fi
.gdbinit: $(srcdir)/util/gdbinit
......
......@@ -73,6 +73,19 @@ EOF
fi
])
dnl --------------------------------------------------------------
dnl Make srcdir absolute, if it isn't already. It's important to
dnl avoid running the path through pwd unnecessarily, since pwd can
dnl give you automounter prefixes, which can go away.
dnl
AC_DEFUN(ECL_MAKE_ABSOLUTE_SRCDIR,[
PWDCMD="pwd";
case "${srcdir}" in
/* | ?:/* ) ;;
* ) srcdir="`(cd ${srcdir}; ${PWDCMD})`";
esac
])
dnl
dnl --------------------------------------------------------------
dnl Define a name for this operating system and set some defaults
......@@ -115,10 +128,14 @@ LIBPREFIX='lib'
LIBEXT='a'
PICFLAG='-fPIC'
LDINSTALLNAME=''
THREAD_CFLAGS=''
THREAD_LDFLAGS=''
case "${host_os}" in
# libdir may have a dollar expression inside
linux*)
thehost='linux'
THREAD_CFLAGS='-D_THREAD_SAFE'
THREAD_LDFLAGS='-lpthread'
SHARED_LDFLAGS="-shared ${LDFLAGS}"
BUNDLE_LDFLAGS="-shared ${LDFLAGS}"
LDRPATH='-Wl,--rpath,~A'
......
......@@ -94,11 +94,11 @@ mangle_name(cl_object output, char *source, int l)
}
}
package= symbol->symbol.hpack;
if (package == lisp_package)
if (package == cl_core.lisp_package)
package = make_simple_string("cl");
else if (package == system_package)
else if (package == cl_core.system_package)
package = make_simple_string("si");
else if (package == keyword_package)
else if (package == cl_core.keyword_package)
package = Cnil;
else
package = package->pack.name;
......@@ -117,7 +117,7 @@ mangle_name(cl_object output, char *source, int l)
source++;
} else if (!is_symbol) {
c = '_';
} else if (package == keyword_package) {
} else if (package == cl_core.keyword_package) {
c = 'K';
} else {
c = 'S';
......@@ -148,13 +148,14 @@ make_this_symbol(int i, cl_object s, int code, const char *name,
case 2: stp = stp_constant; break;
}
switch (code & 12) {
case 0: package = lisp_package; break;
case 4: package = system_package; break;
case 8: package = keyword_package; break;
case 0: package = cl_core.lisp_package; break;
case 4: package = cl_core.system_package; break;
case 8: package = cl_core.keyword_package; break;
}
s->symbol.t = t_symbol;
s->symbol.dynamic = 0;
s->symbol.mflag = FALSE;
SYM_VAL(s) = OBJNULL;
ECL_SET(s, OBJNULL);
SYM_FUN(s) = OBJNULL;
s->symbol.plist = Cnil;
s->symbol.hpack = Cnil;
......@@ -163,11 +164,11 @@ make_this_symbol(int i, cl_object s, int code, const char *name,
s->symbol.isform = FALSE;
s->symbol.hpack = package;
s->symbol.name = make_constant_string(name);
if (package == keyword_package) {
if (package == cl_core.keyword_package) {
sethash(s->symbol.name, package->pack.external, s);
SYM_VAL(s) = s;
ECL_SET(s, s);
} else {
SYM_VAL(s) = value;
ECL_SET(s, value);
cl_import2(s, package);
cl_export2(s, package);
}
......
......@@ -275,8 +275,8 @@ ONCE_MORE:
break;
case t_symbol:
obj->symbol.plist = OBJNULL;
SYM_FUN(obj) = OBJNULL;
SYM_VAL(obj) = OBJNULL;
obj->gfdef = OBJNULL;
obj->value = OBJNULL;
obj->symbol.name = OBJNULL;
break;
case t_package:
......@@ -371,6 +371,11 @@ ONCE_MORE:
obj->thread.entry = OBJNULL;
break;
#endif
#ifdef ECL_THREADS
case t_thread:
obj->thread.env = OBJNULL;
break;
#endif
#ifdef CLOS
case t_instance:
CLASS_OF(obj) = OBJNULL;
......@@ -842,12 +847,6 @@ since ~D pages are already allocated.",
@(return flag)
@)
void
init_alloc_function(void)
{
ignore_maximum_pages = TRUE;
}
#ifdef NEED_MALLOC
/*
UNIX malloc simulator.
......
......@@ -14,8 +14,7 @@
#include "ecl.h"
#include "page.h"
#include "gc.h"
#include "private/gc_priv.h"
#include "gc/gc.h"
#ifdef GBC_BOEHM
......@@ -126,6 +125,7 @@ init_tm(cl_type t, char *name, cl_index elsize)
static int alloc_initialized = FALSE;
extern void (*GC_push_other_roots)();
static void (*old_GC_push_other_roots)();
void
......@@ -172,6 +172,9 @@ init_alloc(void)
#ifdef ECL_FFI
init_tm(t_instance, "FOREIGN", sizeof(struct ecl_foreign));
#endif
#ifdef ECL_THREADS
init_tm(t_thread, "THREAD", sizeof(struct ecl_thread));
#endif
#ifdef THREADS
init_tm(t_cont, "CONT", sizeof(struct ecl_cont));
init_tm(t_thread, "THREAD", sizeof(struct ecl_thread));
......@@ -186,26 +189,55 @@ init_alloc(void)
**********************************************************/
static void
stacks_scanner(void)
ecl_mark_env(struct cl_env_struct *env)
{
#if 1
if (cl_stack) {
GC_push_conditional(cl_stack, cl_stack_top,1);
GC_set_mark_bit(cl_stack);
if (env->stack) {
GC_push_conditional(env->stack, env->stack_top,1);
GC_set_mark_bit(env->stack);
}
if (frs_top) {
GC_push_conditional(frs_org, frs_top+1,1);
GC_set_mark_bit(frs_org);
if (env->frs_top) {
GC_push_conditional(env->frs_org, env->frs_top+1,1);
GC_set_mark_bit(env->frs_org);
}
if (bds_top) {
GC_push_conditional(bds_org, bds_top+1,1);
GC_set_mark_bit(bds_org);
if (env->bds_top) {
GC_push_conditional(env->bds_org, env->bds_top+1,1);
GC_set_mark_bit(env->bds_org);
}
GC_push_all(cl_symbols, cl_symbols + cl_num_symbols_in_core);
GC_push_all(&lex_env, (&lex_env)+1);
#endif
if (NValues)
GC_push_all(Values, Values+NValues+1);
#if 0
GC_push_all(&(env->lex_env), &(env->lex_env)+1);
GC_push_all(&(env->token), &(env->print_base));
GC_push_all(&(env->circle_stack), &(env->qh));
GC_push_all(env->big_register, env->big_register + 3);
if (env->nvalues)
GC_push_all(env->values, env->values + env->nvalues + 1);
#else
/*memset(env->values[env->nvalues], 0, (64-env->nvalues)*sizeof(cl_object));*/
GC_push_all(env, env + 1);
#endif
}
static void
stacks_scanner(void)
{
#ifdef ECL_THREADS
cl_object l = cl_core.threads;
struct cl_env_struct cl_env_ptr;
if (l == OBJNULL) {
ecl_mark_env(&cl_env);
} else {
for (l = cl_core.threads; l != Cnil; l = CDR(l)) {
cl_object thread = CAR(l);
struct cl_env_struct *env = thread->thread.env;
ecl_mark_env(env);
}
}
#else
ecl_mark_env(&cl_env);
#endif
GC_push_all(&cl_core, &cl_core + 1);
GC_push_all(cl_symbols, cl_symbols + cl_num_symbols_in_core);
if (old_GC_push_other_roots)
(*old_GC_push_other_roots)();
}
......
......@@ -24,7 +24,7 @@ cl_set(cl_object var, cl_object val)
FEtype_error_symbol(var);
if (var->symbol.stype == stp_constant)
FEinvalid_variable("Cannot assign to the constant ~S.", var);
return1(SYM_VAL(var) = val);
return1(ECL_SETQ(var, val));
}
@(defun si::fset (fname def &optional macro pprint)
......@@ -66,7 +66,9 @@ cl_makunbound(cl_object sym)
FEtype_error_symbol(sym);
if ((enum ecl_stype)sym->symbol.stype == stp_constant)
FEinvalid_variable("Cannot unbind the constant ~S.", sym);
SYM_VAL(sym) = OBJNULL;
/* FIXME! The semantics of MAKUNBOUND is not very clear with local
bindings ... */
ECL_SET(sym, OBJNULL);
@(return sym)
}
......@@ -112,12 +114,10 @@ record_source_pathname(cl_object sym, cl_object def)
}
#endif /* PDE */
static cl_object system_properties = OBJNULL;
cl_object
si_get_sysprop(cl_object sym, cl_object prop)
{
cl_object plist = gethash_safe(sym, system_properties, Cnil);
cl_object plist = gethash_safe(sym, cl_core.system_properties, Cnil);
@(return ecl_getf(plist, prop, Cnil));
}
......@@ -126,8 +126,8 @@ si_put_sysprop(cl_object sym, cl_object prop, cl_object value)
{
cl_object plist;
assert_type_symbol(sym);
plist = gethash_safe(sym, system_properties, Cnil);
sethash(sym, system_properties, si_put_f(plist, value, prop));
plist = gethash_safe(sym, cl_core.system_properties, Cnil);
sethash(sym, cl_core.system_properties, si_put_f(plist, value, prop));
@(return value);
}
......@@ -136,22 +136,9 @@ si_rem_sysprop(cl_object sym, cl_object prop)
{
cl_object plist, found;
assert_type_symbol(sym);
plist = gethash_safe(sym, system_properties, Cnil);
plist = gethash_safe(sym, cl_core.system_properties, Cnil);
plist = si_rem_f(plist, prop);
found = VALUES(1);
sethash(sym, system_properties, plist);
sethash(sym, cl_core.system_properties, plist);
@(return found);
}
void
init_assignment(void)
{
#ifdef PDE
SYM_VAL(@'si::*record-source-pathname-p*') = Cnil;
#endif
ecl_register_root(&system_properties);
system_properties =
cl__make_hash_table(@'eq', MAKE_FIXNUM(1024), /* size */
make_shortfloat(1.5), /* rehash-size */
make_shortfloat(0.7)); /* rehash-threshold */
}
......@@ -57,8 +57,6 @@ _cl_backq_cdr(cl_object *px)
cl_object x = *px;
int a, d;
cs_check(px);
if (ATOM(x))
return(QUOTE);
if (CAR(x) == @'si::,') {
......@@ -188,8 +186,6 @@ _cl_backq_car(cl_object *px)
cl_object x = *px;
int d;
cs_check(px);
if (ATOM(x))
return(QUOTE);
if (CAR(x) == @'si::,') {
......@@ -267,9 +263,9 @@ cl_object comma_reader(cl_object in, cl_object c)
read_char(in);
} else
x = @'si::,';
SYM_VAL(@'si::*backq-level*') = MAKE_FIXNUM(backq_level-1);
ECL_SETQ(@'si::*backq-level*', MAKE_FIXNUM(backq_level-1));
y = read_object(in);
SYM_VAL(@'si::*backq-level*') = MAKE_FIXNUM(backq_level);
ECL_SETQ(@'si::*backq-level*', MAKE_FIXNUM(backq_level));
@(return CONS(x, y))
}
......@@ -277,9 +273,9 @@ static
cl_object backquote_reader(cl_object in, cl_object c)
{
cl_fixnum backq_level = fix(SYM_VAL(@'si::*backq-level*'));
SYM_VAL(@'si::*backq-level*') = MAKE_FIXNUM(backq_level+1);
ECL_SETQ(@'si::*backq-level*', MAKE_FIXNUM(backq_level+1));
in = read_object(in);
SYM_VAL(@'si::*backq-level*') = MAKE_FIXNUM(backq_level);
ECL_SETQ(@'si::*backq-level*', MAKE_FIXNUM(backq_level));
@(return backq(in))
}
......@@ -290,7 +286,7 @@ init_backq(void)
{
cl_object r;
r = standard_readtable;
r = cl_core.standard_readtable;
r->readtable.table['`'].syntax_type = cat_terminating;
r->readtable.table['`'].macro = make_cf(backquote_reader);
r->readtable.table[','].syntax_type = cat_terminating;
......
......@@ -16,14 +16,6 @@
#include <string.h>
#include "ecl.h"
#ifndef THREADS
cl_object bignum_register[3];
mp_limb_t bignum_register_limbs[3][BIGNUM_REGISTER_SIZE];
#else
#define bignum_register_limbs lwp->lwp_bignum_register_limbs
#define bignum_register lwp->lwp_bignum_register
#endif
/*
* Using GMP multiple precision integers:
*
......@@ -45,34 +37,34 @@ mp_limb_t bignum_register_limbs[3][BIGNUM_REGISTER_SIZE];
cl_object
big_register0_get(void)
{
bignum_register[0]->big.big_size = 0;
return bignum_register[0];
cl_env.big_register[0]->big.big_size = 0;
return cl_env.big_register[0];
}
cl_object
big_register1_get(void)
{
bignum_register[1]->big.big_size = 0;
return bignum_register[1];
cl_env.big_register[1]->big.big_size = 0;
return cl_env.big_register[1];
}
cl_object
big_register2_get(void)
{
bignum_register[2]->big.big_size = 0;
return bignum_register[2];
cl_env.big_register[2]->big.big_size = 0;
return cl_env.big_register[2];
}
void
big_register_free(cl_object x)
{
/* FIXME! Is this thread safe? */
if (x == bignum_register[0])
x->big.big_limbs = bignum_register_limbs[0];
else if (x == bignum_register[1])
x->big.big_limbs = bignum_register_limbs[1];
else if (x == bignum_register[2])
x->big.big_limbs = bignum_register_limbs[2];
if (x == cl_env.big_register[0])
x->big.big_limbs = cl_env.big_register_limbs[0];
else if (x == cl_env.big_register[1])
x->big.big_limbs = cl_env.big_register_limbs[1];
else if (x == cl_env.big_register[2])
x->big.big_limbs = cl_env.big_register_limbs[2];
else
error("big_register_free: unknown register");
x->big.big_size = 0;
......@@ -89,7 +81,7 @@ big_register_copy(cl_object old)
new_big->big = old->big;
big_register_free(old);
} else {
/* As the bignum points to the bignum_register_limbs[] area
/* As the bignum points to the cl_env.big_register_limbs[] area
we must duplicate its contents. */
mpz_init_set(new_big->big.big_num,old->big.big_num);
}
......@@ -282,8 +274,8 @@ static void
mp_free(void *ptr, size_t size)
{
char *x = ptr;
if (x < (char *)(bignum_register_limbs) ||
x > (char *)(bignum_register_limbs+2))
if (x < (char *)(cl_env.big_register_limbs) ||
x > (char *)(cl_env.big_register_limbs+2))
cl_dealloc(x,size);
}
......@@ -292,9 +284,8 @@ init_big(void)
{
int i;
for (i = 0; i < 3; i++) {
bignum_register[i] = cl_alloc_object(t_bignum);
ecl_register_static_root(&bignum_register[i]);
big_register_free(bignum_register[i]);
cl_env.big_register[i] = cl_alloc_object(t_bignum);
big_register_free(cl_env.big_register[i]);
}
mp_set_memory_functions(mp_alloc, mp_realloc, mp_free);
}
......@@ -424,21 +424,21 @@ cl_char_name(cl_object c)
/* INV: char_code() checks the type of `c' */
switch (char_code(c)) {
case '\000':
return1(STnull);
return1(cl_core.string_null);
case '\r':
return1(STreturn);
return1(cl_core.string_return);
case ' ':
return1(STspace);
return1(cl_core.string_space);
case '\177':
return1(STrubout);
return1(cl_core.string_rubout);
case '\f':
return1(STpage);
return1(cl_core.string_page);
case '\t':
return1(STtab);
return1(cl_core.string_tab);
case '\b':
return1(STbackspace);
return1(cl_core.string_backspace);
case '\n':
return1(STnewline);
return1(cl_core.string_newline);
}
return1(Cnil);
}
......@@ -449,47 +449,22 @@ cl_name_char(cl_object s)
char c;
s = cl_string(s);
if (string_equal(s, STreturn))
if (string_equal(s, cl_core.string_return))
c = '\r'; else
if (string_equal(s, STspace))
if (string_equal(s, cl_core.string_space))
c = ' '; else
if (string_equal(s, STrubout))
if (string_equal(s, cl_core.string_rubout))
c = '\177'; else
if (string_equal(s, STpage))
if (string_equal(s, cl_core.string_page))
c = '\f'; else
if (string_equal(s, STtab))
if (string_equal(s, cl_core.string_tab))
c = '\t'; else
if (string_equal(s, STbackspace))
if (string_equal(s, cl_core.string_backspace))
c = '\b'; else
if (string_equal(s, STlinefeed) || string_equal(s, STnewline))
if (string_equal(s, cl_core.string_linefeed) || string_equal(s, cl_core.string_newline))
c = '\n'; else
if (string_equal(s, STnull))
if (string_equal(s, cl_core.string_null))
c = '\000'; else
return1(Cnil);
return1(CODE_CHAR(c));
}
void
init_character(void)
{
SYM_VAL(@'char-code-limit') = MAKE_FIXNUM(CHAR_CODE_LIMIT);
STreturn = make_simple_string("Return");
ecl_register_static_root(&STreturn);
STspace = make_simple_string("Space");
ecl_register_static_root(&STspace);
STrubout = make_simple_string("Rubout");
ecl_register_static_root(&STrubout);
STpage = make_simple_string("Page");
ecl_register_static_root(&STpage);
STtab = make_simple_string("Tab");
ecl_register_static_root(&STtab);
STbackspace = make_simple_string("Backspace");
ecl_register_static_root(&STbackspace);
STlinefeed = make_simple_string("Linefeed");
ecl_register_static_root(&STlinefeed);
STnull = make_simple_string("Null");
ecl_register_static_root(&STnull);
STnewline = make_simple_string("Newline");
ecl_register_static_root(&STnewline);
}
......@@ -18,7 +18,6 @@
static cl_object si_simple_toplevel ()
{
cl_object sentence;
cl_object lex_old = lex_env;
int i;
/* Simple minded top level loop */
......@@ -27,7 +26,6 @@ static cl_object si_simple_toplevel ()
#ifdef TK
StdinResume();
#endif
lex_new();
for (i = 1; i<fix(si_argc()); i++) {
cl_object arg = si_argv(MAKE_FIXNUM(i));
cl_load(1, arg);
......@@ -42,7 +40,6 @@ static cl_object si_simple_toplevel ()
StdinResume();
#endif
}
lex_env = lex_old;
}
int
......@@ -53,7 +50,7 @@ main(int argc, char **args)
/* This should be always the first call */
cl_boot(argc, args);
SYM_VAL(@'*package*') = system_package;
SYM_VAL(@'*package*') = cl_core.system_package;
SYM_VAL(@'*features*') = CONS(make_keyword("ECL-MIN"), SYM_VAL(@'*features*'));
#ifdef CLOS
SYM_VAL(@'*features*') = CONS(make_keyword("WANTS-CLOS"), SYM_VAL(@'*features*'));
......@@ -64,7 +61,7 @@ main(int argc, char **args)
#ifdef CLX
SYM_VAL(@'*features*') = CONS(make_keyword("WANTS-CLX"), SYM_VAL(@'*features*'));
#endif
top_level = _intern("TOP-LEVEL", system_package);
top_level = _intern("TOP-LEVEL", cl_core.system_package);
cl_def_c_function(top_level, si_simple_toplevel, 0);
funcall(1, top_level);
return(0);
......
......@@ -177,7 +177,7 @@ cl_go(cl_object tag_id, cl_object label)
if (fr == NULL)
FEcontrol_error("GO: The tagbody ~S is missing.", 1, tag_id);
VALUES(0)=label;
NValues=1;
NVALUES=1;
unwind(fr);
}
......@@ -278,11 +278,3 @@ check_other_key(cl_object l, int n, ...)
FEprogram_error("The keyword ~S is not allowed or is duplicated.",
1, other_key);
}
void
init_cmpaux(void)
{
SYM_VAL(@'LAMBDA-LIST-KEYWORDS') =
cl_list(8, @'&optional', @'&rest', @'&key', @'&allow-other-keys', @'&aux',
@'&whole', @'&environment', @'&body');
}
This diff is collapsed.
......@@ -119,9 +119,8 @@ NO_KEYS:
static cl_opcode *
disassemble_dolist(cl_object bytecodes, cl_opcode *vector) {
cl_opcode *exit, *output;
cl_object lex_old = lex_env;
cl_object lex_old = cl_env.lex_env;
lex_copy();
GET_LABEL(exit, vector);
GET_LABEL(output, vector);
print_oparg("DOLIST\t", exit-base);
......@@ -132,7 +131,7 @@ disassemble_dolist(cl_object bytecodes, cl_opcode *vector) {
vector = disassemble(bytecodes, vector);
print_noarg("\t\t; dolist");
lex_env = lex_old;
cl_env.lex_env = lex_old;
return vector;
}
......@@ -152,9 +151,8 @@ disassemble_dolist(cl_object bytecodes, cl_opcode *vector) {
static cl_opcode *
disassemble_dotimes(cl_object bytecodes, cl_opcode *vector) {
cl_opcode *exit, *output;
cl_object lex_old = lex_env;
cl_object lex_old = cl_env.lex_env;
lex_copy();
GET_LABEL(exit, vector);
GET_LABEL(output, vector);
print_oparg("DOTIMES\t", exit-base);
......@@ -165,7 +163,7 @@ disassemble_dotimes(cl_object bytecodes, cl_opcode *vector) {
vector = disassemble(bytecodes, vector);
print_noarg("\t\t; dotimes");
lex_env = lex_old;
cl_env.lex_env = lex_old;
return vector;
}
......@@ -276,9 +274,8 @@ labeln:
static cl_opcode *
disassemble_tagbody(cl_object bytecodes, cl_opcode *vector) {
cl_index i, ntags = GET_OPARG(vector);
cl_object lex_old = lex_env;
cl_object lex_old = cl_env.lex_env;
cl_opcode *destination;
lex_copy();