From 0c4c43b05285ed15e3e52d1f3131296539336366 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 26 Jun 2008 21:05:48 +0000 Subject: [PATCH 01/16] When ECL_OFFSET_TABLE is empty, there is a syntax error in C --- src/c/interpreter.d | 2 +- src/h/bytecodes.h | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 65d246404..05efe8ddd 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -501,7 +501,7 @@ close_around(cl_object fun, cl_object lex) { cl_object ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offset) { - ECL_OFFSET_TABLE; + ECL_OFFSET_TABLE typedef struct cl_env_struct *cl_env_ptr; const cl_env_ptr the_env = &cl_env; volatile bds_ptr old_bds_top = cl_env.bds_top; diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index 26228ce25..ff0238f17 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -243,5 +243,5 @@ typedef int16_t cl_oparg; &&LBL_OP_PUSHNIL - &&LBL_OP_NOP,\ &&LBL_OP_STEPIN - &&LBL_OP_NOP,\ &&LBL_OP_STEPCALL - &&LBL_OP_NOP,\ - &&LBL_OP_STEPOUT - &&LBL_OP_NOP } + &&LBL_OP_STEPOUT - &&LBL_OP_NOP }; #endif From faa259203e54aa3fb8cf6a8ac60d236fd7eb760c Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 26 Jun 2008 21:06:09 +0000 Subject: [PATCH 02/16] Automatic initialization of GC library uses ECL's usual flags --- src/gc/win32_threads.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/gc/win32_threads.c b/src/gc/win32_threads.c index 742b3bb15..239d2d7ae 100755 --- a/src/gc/win32_threads.c +++ b/src/gc/win32_threads.c @@ -545,6 +545,8 @@ int WINAPI WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, DWORD thread_id; /* initialize everything */ + GC_all_interior_pointers = 0; + GC_no_dls = 1; GC_init(); /* start the main thread */ @@ -764,6 +766,8 @@ BOOL WINAPI DllMain(HINSTANCE inst, ULONG reason, LPVOID reserved) { switch (reason) { case DLL_PROCESS_ATTACH: + GC_no_dls = 1; + GC_all_interior_pointers = 0; GC_init(); /* Force initialization before thread attach. */ /* fall through */ case DLL_THREAD_ATTACH: From aa099a332a4e00660628bf30030c5a9fca856b03 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Fri, 27 Jun 2008 20:18:12 +0000 Subject: [PATCH 03/16] Implement SI:MAKE-PIPE (By S. Gromoff). Eliminate OPEN-PIPE / CLOSE-PIPE. --- src/CHANGELOG | 6 ++++++ src/c/symbols_list.h | 3 +-- src/c/symbols_list2.h | 3 +-- src/c/unixsys.d | 48 ++++++++++++++----------------------------- src/h/external.h | 3 +-- 5 files changed, 24 insertions(+), 39 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 7ba19d149..a947dc279 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -136,6 +136,12 @@ ECL 0.9k: - Accessors for low-level socket timeout attributes (by G. Carncross). + - The function EXT:OPEN-PIPE disappears, together with EXT:CLOSE-PIPE. Use + EXT:RUN-PROCESS instead. + + - New function EXT:MAKE-PIPE implements the equivalent of POSIX pipe() but + producing a two-way stream. + * CLOS: - When caching generic function calls, ECL now uses a thread-local hash table diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 44ce2d16b..72f6d9dea 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1079,7 +1079,6 @@ cl_symbols[] = { {SYS_ "CHAR-SET", SI_ORDINARY, si_char_set, 3, OBJNULL}, {SYS_ "CHDIR", SI_ORDINARY, si_chdir, -1, OBJNULL}, {SYS_ "CLEAR-COMPILER-PROPERTIES", SI_ORDINARY, cl_identity, 1, OBJNULL}, -{SYS_ "CLOSE-PIPE", SI_ORDINARY, si_close_pipe, 1, OBJNULL}, {SYS_ "COERCE-TO-BASE-STRING", SI_ORDINARY, si_coerce_to_base_string, 1, OBJNULL}, {SYS_ "COERCE-TO-EXTENDED-STRING", SI_ORDINARY, si_coerce_to_extended_string, 1, OBJNULL}, {SYS_ "COERCE-TO-FILENAME", SI_ORDINARY, si_coerce_to_filename, 1, OBJNULL}, @@ -1141,7 +1140,7 @@ cl_symbols[] = { {SYS_ "MKDIR", SI_ORDINARY, si_mkdir, 2, OBJNULL}, {SYS_ "MKSTEMP", SI_ORDINARY, si_mkstemp, 1, OBJNULL}, {SYS_ "RMDIR", SI_ORDINARY, si_rmdir, 1, OBJNULL}, -{SYS_ "OPEN-PIPE", SI_ORDINARY, si_open_pipe, 1, OBJNULL}, +{SYS_ "MAKE-PIPE", SI_ORDINARY, si_make_pipe, 0, OBJNULL}, {SYS_ "PACKAGE-LOCK", SI_ORDINARY, si_package_lock, 2, OBJNULL}, {SYS_ "PACKAGE-HASH-TABLES", SI_ORDINARY, si_package_hash_tables, 1, OBJNULL}, {SYS_ "PATHNAME-TRANSLATIONS", SI_ORDINARY, si_pathname_translations, -1, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 704b96f57..6bf64b152 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1079,7 +1079,6 @@ cl_symbols[] = { {SYS_ "CHAR-SET","si_char_set"}, {SYS_ "CHDIR","si_chdir"}, {SYS_ "CLEAR-COMPILER-PROPERTIES","cl_identity"}, -{SYS_ "CLOSE-PIPE","si_close_pipe"}, {SYS_ "COERCE-TO-BASE-STRING","si_coerce_to_base_string"}, {SYS_ "COERCE-TO-EXTENDED-STRING","si_coerce_to_extended_string"}, {SYS_ "COERCE-TO-FILENAME","si_coerce_to_filename"}, @@ -1141,7 +1140,7 @@ cl_symbols[] = { {SYS_ "MKDIR","si_mkdir"}, {SYS_ "MKSTEMP","si_mkstemp"}, {SYS_ "RMDIR","si_rmdir"}, -{SYS_ "OPEN-PIPE","si_open_pipe"}, +{SYS_ "MAKE-PIPE","si_make_pipe"}, {SYS_ "PACKAGE-LOCK","si_package_lock"}, {SYS_ "PACKAGE-HASH-TABLES","si_package_hash_tables"}, {SYS_ "PATHNAME-TRANSLATIONS","si_pathname_translations"}, diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 213a66e33..338253063 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -49,44 +49,26 @@ si_getpid(void) } cl_object -si_open_pipe(cl_object cmd_string) +si_make_pipe() { + cl_object output; + int fds[2], ret; #ifdef _MSC_VER - FEerror("Pipes are not supported under Win32/MSVC", 0); + ret = _pipe(fds, 4096, _O_BINARY); #else - FILE *ptr; - cl_object stream; - cl_object cmd = si_copy_to_simple_base_string(cmd); - ptr = popen(cmd->base_string.self, "r"); - if (ptr == NULL) - @(return Cnil); - stream = cl_alloc_object(t_stream); - stream->stream.mode = smm_input; - stream->stream.file = ptr; - stream->stream.object0 = @'base-char'; - stream->stream.char_stream_p = 1; - stream->stream.object1 = @'si::open-pipe'; - stream->stream.int0 = stream->stream.int1 = 0; - si_set_buffering_mode(stream, @':line-buffered'); - @(return stream) + ret = pipe(fds); #endif -} - -cl_object -si_close_pipe(cl_object stream) -{ -#ifdef _MSC_VER - FEerror("Pipes are not supported under Win32/MSVC", 0); -#else - if (type_of(stream) == t_stream && - stream->stream.object1 == @'si::open-pipe') { - stream->stream.closed = 1; - pclose(stream->stream.file); - stream->stream.file = NULL; - stream->stream.object0 = OBJNULL; + if (ret < 0) { + FElibc_error("Unable to create pipe", 0); + output = Cnil; + } else { + cl_object fake_in_name = make_simple_base_string("PIPE-READ-ENDPOINT"); + cl_object in = ecl_make_stream_from_fd(fake_in_name, fds[0], smm_input); + cl_object fake_out_name = make_simple_base_string("PIPE-WRITE-ENDPOINT"); + cl_object out = ecl_make_stream_from_fd(fake_out_name, fds[1], smm_output); + output = cl_make_two_way_stream(in, out); } - @(return) -#endif + @(return output) } @(defun ext::run-program (command argv &key (input @':stream') (output @':stream') diff --git a/src/h/external.h b/src/h/external.h index c372053f3..4f0c8a535 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -1530,8 +1530,7 @@ extern ECL_API cl_object si_trap_fpe(cl_object condition, cl_object flag); /* unixsys.c */ extern ECL_API cl_object si_system(cl_object cmd); -extern ECL_API cl_object si_open_pipe(cl_object cmd); -extern ECL_API cl_object si_close_pipe(cl_object stream); +extern ECL_API cl_object si_make_pipe(); extern ECL_API cl_object si_run_program _ARGS((cl_narg narg, cl_object command, cl_object args, ...)); From 0e657faf79549b6fd1569855ab088940199fbeba Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Sat, 28 Jun 2008 07:57:39 +0000 Subject: [PATCH 04/16] Complete the fix for LONG_FLOAT. --- src/h/object.h | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/h/object.h b/src/h/object.h index b24bc882e..9e4f69ec7 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -164,8 +164,7 @@ struct ecl_doublefloat { #define df(obje) (obje)->DF.DFVAL #define ecl_double_float(o) ((o)->doublefloat.value) -#ifdef HAVE_LONG_DOUBLE -#define ECL_LONG_FLOAT +#ifdef ECL_LONG_FLOAT struct ecl_long_float { HEADER; long double value; From 90e936d85ccdee2932303d5189212e3fed1772af Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Sat, 28 Jun 2008 08:22:14 +0000 Subject: [PATCH 05/16] There is not finitel(), so just use coercion. --- src/c/number.d | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/c/number.d b/src/c/number.d index c745c122a..54d63a241 100644 --- a/src/c/number.d +++ b/src/c/number.d @@ -203,7 +203,7 @@ make_longfloat(long double f) if (isnanl(f)) { cl_error(1, @'division-by-zero'); } - if (!finitel(f)) { + if (!finite(f)) { cl_error(1, @'floating-point-overflow'); } x = cl_alloc_object(t_longfloat); From 982a31133a71213848eb89d094bfdcc91a4eba5c Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Sat, 28 Jun 2008 08:36:21 +0000 Subject: [PATCH 06/16] Fixed the flags for the statically linked ECL --- src/compile.lsp.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/compile.lsp.in b/src/compile.lsp.in index 7dff27025..916052e0f 100644 --- a/src/compile.lsp.in +++ b/src/compile.lsp.in @@ -45,7 +45,7 @@ c::*ecl-library-directory* "@true_builddir@/") #-:wants-dlopen (setf c::*ld-flags* - "@LDFLAGS@ @LDRPATH@ @LIBPREFIX@ecl.@LIBEXT@ @CORE_LIBS@ @LIBS@ @FASL_LIBS@") + "@LDFLAGS@ @LIBPREFIX@ecl.@LIBEXT@ @CORE_LIBS@ @LIBS@ @FASL_LIBS@") #+(and :wants-dlopen (not nonstop)) (setf c::*ld-flags* "@LDFLAGS@ @SHAREDPREFIX@ecl.@SHAREDEXT@ @LIBS@" From 07e49ba844e1859fa671981725ae76d53ccbf32d Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Sat, 28 Jun 2008 18:13:40 +0000 Subject: [PATCH 07/16] Simplify code slightly by removing all direct references to VALUES and NVALUES. --- src/c/num_co.d | 328 ++++++++++++++++++++++++------------------------- 1 file changed, 164 insertions(+), 164 deletions(-) diff --git a/src/c/num_co.d b/src/c/num_co.d index 10e532104..d2b8fb807 100644 --- a/src/c/num_co.d +++ b/src/c/num_co.d @@ -145,46 +145,47 @@ cl_denominator(cl_object x) cl_object ecl_floor1(cl_object x) { + cl_object v0, v1; AGAIN: switch (type_of(x)) { case t_fixnum: case t_bignum: - VALUES(0) = x; - VALUES(1) = MAKE_FIXNUM(0); + v0 = x; + v1 = MAKE_FIXNUM(0); break; case t_ratio: - VALUES(0) = ecl_floor2(x->ratio.num, x->ratio.den); - VALUES(1) = ecl_make_ratio(VALUES(1), x->ratio.den); + v0 = ecl_floor2(x->ratio.num, x->ratio.den); + v1 = ecl_make_ratio(VALUES(1), x->ratio.den); break; #ifdef ECL_SHORT_FLOAT case t_shortfloat: { float d = ecl_short_float(x); float y = floorf(d); - VALUES(0) = float_to_integer(y); - VALUES(1) = make_shortfloat(d - y); + v0 = float_to_integer(y); + v1 = make_shortfloat(d - y); break; } #endif case t_singlefloat: { float d = sf(x); float y = floorf(d); - VALUES(0) = float_to_integer(y); - VALUES(1) = ecl_make_singlefloat(d - y); + v0 = float_to_integer(y); + v1 = ecl_make_singlefloat(d - y); break; } case t_doublefloat: { double d = df(x); double y = floor(d); - VALUES(0) = double_to_integer(y); - VALUES(1) = ecl_make_doublefloat(d - y); + v0 = double_to_integer(y); + v1 = ecl_make_doublefloat(d - y); break; } #ifdef ECL_LONG_FLOAT case t_longfloat: { long double d = ecl_long_float(x); long double y = floorl(d); - VALUES(0) = long_double_to_integer(y); - VALUES(1) = make_longfloat(d - y); + v0 = long_double_to_integer(y); + v1 = make_longfloat(d - y); break; } #endif @@ -192,13 +193,13 @@ ecl_floor1(cl_object x) x = ecl_type_error(@'floor',"argument",x,@'real'); goto AGAIN; } - NVALUES = 2; - return VALUES(0); + @(return v0 v1) } cl_object ecl_floor2(cl_object x, cl_object y) { + cl_object v0, v1; cl_type ty; AGAIN: while ((ty = type_of(y), !ECL_NUMBER_TYPE_P(ty))) { @@ -211,11 +212,11 @@ ecl_floor2(cl_object x, cl_object y) cl_fixnum a = fix(x), b = fix(y); cl_fixnum q = a / b, r = a % b; if ((r^b) < 0 && r) { /* opposite sign and some remainder*/ - VALUES(0) = MAKE_FIXNUM(q-1); - VALUES(1) = MAKE_FIXNUM(r+b); + v0 = MAKE_FIXNUM(q-1); + v1 = MAKE_FIXNUM(r+b); } else { - VALUES(0) = MAKE_FIXNUM(q); - VALUES(1) = MAKE_FIXNUM(r); + v0 = MAKE_FIXNUM(q); + v1 = MAKE_FIXNUM(r); } break; } @@ -235,21 +236,21 @@ ecl_floor2(cl_object x, cl_object y) q->big.big_num = (big_num_t)fix(x) / y->big.big_num; r->big.big_num = (big_num_t)fix(x) % y->big.big_num; #endif /* WITH_GMP */ - VALUES(0) = big_register_normalize(q); - VALUES(1) = big_register_normalize(r); + v0 = big_register_normalize(q); + v1 = big_register_normalize(r); break; } case t_ratio: /* FIX / RAT */ - ecl_floor2(ecl_times(x, y->ratio.den), y->ratio.num); - VALUES(1) = ecl_make_ratio(VALUES(1), y->ratio.den); + v0 = ecl_floor2(ecl_times(x, y->ratio.den), y->ratio.num); + v1 = ecl_make_ratio(VALUES(1), y->ratio.den); break; #ifdef ECL_SHORT_FLOAT case t_shortfloat: { /* FIX / SF */ float n = ecl_short_float(y); float p = fix(x) / n; float q = floorf(p); - VALUES(0) = float_to_integer(q); - VALUES(1) = make_shortfloat((p - q)*n); + v0 = float_to_integer(q); + v1 = make_shortfloat((p - q)*n); break; } #endif @@ -257,16 +258,16 @@ ecl_floor2(cl_object x, cl_object y) float n = sf(y); float p = fix(x) / n; float q = floorf(p); - VALUES(0) = float_to_integer(q); - VALUES(1) = ecl_make_singlefloat((p - q)*n); + v0 = float_to_integer(q); + v1 = ecl_make_singlefloat((p - q)*n); break; } case t_doublefloat: { /* FIX / DF */ double n = df(y); double p = fix(x) / n; double q = floor(p); - VALUES(0) = double_to_integer(q); - VALUES(1) = ecl_make_doublefloat((p - q)*n); + v0 = double_to_integer(q); + v1 = ecl_make_doublefloat((p - q)*n); break; } #ifdef ECL_LONG_FLOAT @@ -274,8 +275,8 @@ ecl_floor2(cl_object x, cl_object y) long double n = ecl_long_float(y); long double p = fix(x) / n; long double q = floorl(p); - VALUES(0) = long_double_to_integer(q); - VALUES(1) = make_longfloat((p - q)*n); + v0 = long_double_to_integer(q); + v1 = make_longfloat((p - q)*n); break; } #endif @@ -296,8 +297,8 @@ ecl_floor2(cl_object x, cl_object y) q->big.big_num = x->big.big_num / fix(y); r->big.big_num = x->big.big_num % fix(y); #endif /* WITH_GMP */ - VALUES(0) = big_register_normalize(q); - VALUES(1) = big_register_normalize(r); + v0 = big_register_normalize(q); + v1 = big_register_normalize(r); break; } case t_bignum: { /* BIG / BIG */ @@ -309,21 +310,21 @@ ecl_floor2(cl_object x, cl_object y) q = x->big.big_num / y->big.big_num; r = x->big.big_num % y->big.big_num; #endif /* WITH_GMP */ - VALUES(0) = big_register_normalize(q); - VALUES(1) = big_register_normalize(r); + v0 = big_register_normalize(q); + v1 = big_register_normalize(r); break; } case t_ratio: /* BIG / RAT */ - ecl_floor2(ecl_times(x, y->ratio.den), y->ratio.num); - VALUES(1) = ecl_make_ratio(VALUES(1), y->ratio.den); + v0 = ecl_floor2(ecl_times(x, y->ratio.den), y->ratio.num); + v1 = ecl_make_ratio(VALUES(1), y->ratio.den); break; #ifdef ECL_SHORT_FLOAT case t_shortfloat: { /* BIG / SF */ float n = ecl_short_float(y); float p = big_to_double(x) / n; float q = floorf(p); - VALUES(0) = float_to_integer(q); - VALUES(1) = make_shortfloat((p - q)*n); + v0 = float_to_integer(q); + v1 = make_shortfloat((p - q)*n); break; } #endif @@ -331,16 +332,16 @@ ecl_floor2(cl_object x, cl_object y) float n = sf(y); float p = big_to_double(x) / n; float q = floorf(p); - VALUES(0) = float_to_integer(q); - VALUES(1) = ecl_make_singlefloat((p - q)*n); + v0 = float_to_integer(q); + v1 = ecl_make_singlefloat((p - q)*n); break; } case t_doublefloat: { /* BIG / DF */ double n = df(y); double p = big_to_double(x) / n; double q = floor(p); - VALUES(0) = double_to_integer(q); - VALUES(1) = ecl_make_doublefloat((p - q)*n); + v0 = double_to_integer(q); + v1 = ecl_make_doublefloat((p - q)*n); break; } #ifdef ECL_LONG_FLOAT @@ -348,8 +349,8 @@ ecl_floor2(cl_object x, cl_object y) long double n = ecl_long_float(y); long double p = big_to_double(x) / n; long double q = floorl(p); - VALUES(0) = long_double_to_integer(q); - VALUES(1) = make_longfloat((p - q)*n); + v0 = long_double_to_integer(q); + v1 = make_longfloat((p - q)*n); break; } #endif @@ -360,13 +361,13 @@ ecl_floor2(cl_object x, cl_object y) case t_ratio: switch(ty) { case t_ratio: /* RAT / RAT */ - ecl_floor2(ecl_times(x->ratio.num, y->ratio.den), - ecl_times(x->ratio.den, y->ratio.num)); - VALUES(1) = ecl_make_ratio(VALUES(1), ecl_times(x->ratio.den, y->ratio.den)); + v0 = ecl_floor2(ecl_times(x->ratio.num, y->ratio.den), + ecl_times(x->ratio.den, y->ratio.num)); + v1 = ecl_make_ratio(VALUES(1), ecl_times(x->ratio.den, y->ratio.den)); break; default: /* RAT / ANY */ - ecl_floor2(x->ratio.num, ecl_times(x->ratio.den, y)); - VALUES(1) = ecl_divide(VALUES(1), x->ratio.den); + v0 = ecl_floor2(x->ratio.num, ecl_times(x->ratio.den, y)); + v1 = ecl_divide(VALUES(1), x->ratio.den); } break; #ifdef ECL_SHORT_FLOAT @@ -374,8 +375,8 @@ ecl_floor2(cl_object x, cl_object y) float n = ecl_to_double(y); float p = sf(x)/n; float q = floorf(p); - VALUES(0) = float_to_integer(q); - VALUES(1) = make_shortfloat((p - q)*n); + v0 = float_to_integer(q); + v1 = make_shortfloat((p - q)*n); break; } #endif @@ -383,16 +384,16 @@ ecl_floor2(cl_object x, cl_object y) float n = ecl_to_double(y); float p = sf(x)/n; float q = floorf(p); - VALUES(0) = float_to_integer(q); - VALUES(1) = ecl_make_singlefloat((p - q)*n); + v0 = float_to_integer(q); + v1 = ecl_make_singlefloat((p - q)*n); break; } case t_doublefloat: { /* DF / ANY */ double n = ecl_to_double(y); double p = df(x)/n; double q = floor(p); - VALUES(0) = double_to_integer(q); - VALUES(1) = ecl_make_doublefloat((p - q)*n); + v0 = double_to_integer(q); + v1 = ecl_make_doublefloat((p - q)*n); break; } #ifdef ECL_LONG_FLOAT @@ -400,8 +401,8 @@ ecl_floor2(cl_object x, cl_object y) long double n = ecl_to_long_double(y); long double p = ecl_long_float(x)/n; long double q = floorl(p); - VALUES(0) = long_double_to_integer(q); - VALUES(1) = make_longfloat((p - q)*n); + v0 = long_double_to_integer(q); + v1 = make_longfloat((p - q)*n); break; } #endif @@ -409,62 +410,62 @@ ecl_floor2(cl_object x, cl_object y) x = ecl_type_error(@'floor',"argument",x,@'real'); goto AGAIN; } - NVALUES = 2; - return VALUES(0); + @(return v0 v1) } @(defun floor (x &optional (y OBJNULL)) @ if (narg == 1) - ecl_floor1(x); + x = ecl_floor1(x); else - ecl_floor2(x, y); - returnn(VALUES(0)); + x = ecl_floor2(x, y); + returnn(x); @) cl_object ecl_ceiling1(cl_object x) { + cl_object v0, v1; AGAIN: switch (type_of(x)) { case t_fixnum: case t_bignum: - VALUES(0) = x; - VALUES(1) = MAKE_FIXNUM(0); + v0 = x; + v1 = MAKE_FIXNUM(0); break; case t_ratio: - VALUES(0) = ecl_ceiling2(x->ratio.num, x->ratio.den); - VALUES(1) = ecl_make_ratio(VALUES(1), x->ratio.den); + v0 = ecl_ceiling2(x->ratio.num, x->ratio.den); + v1 = ecl_make_ratio(VALUES(1), x->ratio.den); break; #ifdef ECL_SHORT_FLOAT case t_shortfloat: { float d = ecl_short_float(x); float y = ceilf(d); - VALUES(0) = float_to_integer(y); - VALUES(1) = make_shortfloat(d - y); + v0 = float_to_integer(y); + v1 = make_shortfloat(d - y); break; } #endif case t_singlefloat: { float d = sf(x); float y = ceilf(d); - VALUES(0) = float_to_integer(y); - VALUES(1) = ecl_make_singlefloat(d - y); + v0 = float_to_integer(y); + v1 = ecl_make_singlefloat(d - y); break; } case t_doublefloat: { double d = df(x); double y = ceil(d); - VALUES(0) = double_to_integer(y); - VALUES(1) = ecl_make_doublefloat(d - y); + v0 = double_to_integer(y); + v1 = ecl_make_doublefloat(d - y); break; } #ifdef ECL_LONG_FLOAT case t_longfloat: { long double d = ecl_long_float(x); long double y = ceill(d); - VALUES(0) = long_double_to_integer(y); - VALUES(1) = make_longfloat(d - y); + v0 = long_double_to_integer(y); + v1 = make_longfloat(d - y); break; } #endif @@ -472,13 +473,13 @@ ecl_ceiling1(cl_object x) x = ecl_type_error(@'ceiling',"argument",x,@'real'); goto AGAIN; } - NVALUES = 2; - return VALUES(0); + @(return v0 v1) } cl_object ecl_ceiling2(cl_object x, cl_object y) { + cl_object v0, v1; cl_type ty; AGAIN: while ((ty = type_of(y), !ECL_NUMBER_TYPE_P(ty))) { @@ -491,11 +492,11 @@ ecl_ceiling2(cl_object x, cl_object y) cl_fixnum a = fix(x); cl_fixnum b = fix(y); cl_fixnum q = a / b; cl_fixnum r = a % b; if ((r^b) > 0 && r) { /* same signs and some remainder */ - VALUES(0) = MAKE_FIXNUM(q+1); - VALUES(1) = MAKE_FIXNUM(r-b); + v0 = MAKE_FIXNUM(q+1); + v1 = MAKE_FIXNUM(r-b); } else { - VALUES(0) = MAKE_FIXNUM(q); - VALUES(1) = MAKE_FIXNUM(r); + v0 = MAKE_FIXNUM(q); + v1 = MAKE_FIXNUM(r); } break; } @@ -515,21 +516,21 @@ ecl_ceiling2(cl_object x, cl_object y) q = (big_num_t)fix(x) / y->big.big_num; r = (big_num_t)fix(x) % y->big.big_num; #endif /* WITH_GMP */ - VALUES(0) = big_register_normalize(q); - VALUES(1) = big_register_normalize(r); + v0 = big_register_normalize(q); + v1 = big_register_normalize(r); break; } case t_ratio: /* FIX / RAT */ - ecl_ceiling2(ecl_times(x, y->ratio.den), y->ratio.num); - VALUES(1) = ecl_make_ratio(VALUES(1), y->ratio.den); + v0 = ecl_ceiling2(ecl_times(x, y->ratio.den), y->ratio.num); + v1 = ecl_make_ratio(VALUES(1), y->ratio.den); break; #ifdef ECL_SHORT_FLOAT case t_shortfloat: { /* FIX / SF */ float n = ecl_short_float(y); float p = fix(x)/n; float q = ceilf(p); - VALUES(0) = float_to_integer(q); - VALUES(1) = ecl_make_singlefloat((p - q)*n); + v0 = float_to_integer(q); + v1 = ecl_make_singlefloat((p - q)*n); break; } #endif @@ -537,16 +538,16 @@ ecl_ceiling2(cl_object x, cl_object y) float n = sf(y); float p = fix(x)/n; float q = ceilf(p); - VALUES(0) = float_to_integer(q); - VALUES(1) = ecl_make_singlefloat((p - q)*n); + v0 = float_to_integer(q); + v1 = ecl_make_singlefloat((p - q)*n); break; } case t_doublefloat: { /* FIX / DF */ double n = df(y); double p = fix(x)/n; double q = ceil(p); - VALUES(0) = double_to_integer(q); - VALUES(1) = ecl_make_doublefloat((p - q)*n); + v0 = double_to_integer(q); + v1 = ecl_make_doublefloat((p - q)*n); break; } #ifdef ECL_LONG_FLOAT @@ -554,8 +555,8 @@ ecl_ceiling2(cl_object x, cl_object y) long double n = ecl_long_float(y); long double p = fix(x)/n; long double q = ceill(p); - VALUES(0) = long_double_to_integer(q); - VALUES(1) = make_longfloat((p - q)*n); + v0 = long_double_to_integer(q); + v1 = make_longfloat((p - q)*n); break; } #endif @@ -576,8 +577,8 @@ ecl_ceiling2(cl_object x, cl_object y) q = x->big.big_num / fix(y); r = x->big.big_num % fix(y); #endif /* WITH_GMP */ - VALUES(0) = big_register_normalize(q); - VALUES(1) = big_register_normalize(r); + v0 = big_register_normalize(q); + v1 = big_register_normalize(r); break; } case t_bignum: { /* BIG / BIG */ @@ -589,21 +590,21 @@ ecl_ceiling2(cl_object x, cl_object y) q->big.big_num = x->big.big_num / y->big.big_num; r->big.big_num = x->big.big_num % y->big.big_num; #endif /* WITH_GMP */ - VALUES(0) = big_register_normalize(q); - VALUES(1) = big_register_normalize(r); + v0 = big_register_normalize(q); + v1 = big_register_normalize(r); break; } case t_ratio: /* BIG / RAT */ - ecl_ceiling2(ecl_times(x, y->ratio.den), y->ratio.num); - VALUES(1) = ecl_make_ratio(VALUES(1), y->ratio.den); + v0 = ecl_ceiling2(ecl_times(x, y->ratio.den), y->ratio.num); + v1 = ecl_make_ratio(VALUES(1), y->ratio.den); break; #ifdef ECL_SHORT_FLOAT case t_shortfloat: { /* BIG / SF */ float n = ecl_short_float(y); float p = big_to_double(x)/n; float q = ceilf(p); - VALUES(0) = float_to_integer(q); - VALUES(1) = make_shortfloat((p - q)*n); + v0 = float_to_integer(q); + v1 = make_shortfloat((p - q)*n); break; } #endif @@ -611,16 +612,16 @@ ecl_ceiling2(cl_object x, cl_object y) float n = sf(y); float p = big_to_double(x)/n; float q = ceilf(p); - VALUES(0) = float_to_integer(q); - VALUES(1) = ecl_make_singlefloat((p - q)*n); + v0 = float_to_integer(q); + v1 = ecl_make_singlefloat((p - q)*n); break; } case t_doublefloat: { /* BIG / DF */ double n = df(y); double p = big_to_double(x)/n; double q = ceil(p); - VALUES(0) = double_to_integer(q); - VALUES(1) = ecl_make_doublefloat((p - q)*n); + v0 = double_to_integer(q); + v1 = ecl_make_doublefloat((p - q)*n); break; } #ifdef ECL_LONG_FLOAT @@ -628,8 +629,8 @@ ecl_ceiling2(cl_object x, cl_object y) long double n = ecl_long_float(y); long double p = big_to_double(x)/n; long double q = ceill(p); - VALUES(0) = long_double_to_integer(q); - VALUES(1) = make_longfloat((p - q)*n); + v0 = long_double_to_integer(q); + v1 = make_longfloat((p - q)*n); break; } #endif @@ -640,13 +641,13 @@ ecl_ceiling2(cl_object x, cl_object y) case t_ratio: switch(type_of(y)) { case t_ratio: /* RAT / RAT */ - ecl_ceiling2(ecl_times(x->ratio.num, y->ratio.den), - ecl_times(x->ratio.den, y->ratio.num)); - VALUES(1) = ecl_make_ratio(VALUES(1), ecl_times(x->ratio.den, y->ratio.den)); + v0 = ecl_ceiling2(ecl_times(x->ratio.num, y->ratio.den), + ecl_times(x->ratio.den, y->ratio.num)); + v1 = ecl_make_ratio(VALUES(1), ecl_times(x->ratio.den, y->ratio.den)); break; default: /* RAT / ANY */ - ecl_ceiling2(x->ratio.num, ecl_times(x->ratio.den, y)); - VALUES(1) = ecl_divide(VALUES(1), x->ratio.den); + v0 = ecl_ceiling2(x->ratio.num, ecl_times(x->ratio.den, y)); + v1 = ecl_divide(VALUES(1), x->ratio.den); } break; #ifdef ECL_SHORT_FLOAT @@ -654,8 +655,8 @@ ecl_ceiling2(cl_object x, cl_object y) float n = ecl_to_double(y); float p = sf(x)/n; float q = ceilf(p); - VALUES(0) = float_to_integer(q); - VALUES(1) = make_shortfloat((p - q)*n); + v0 = float_to_integer(q); + v1 = make_shortfloat((p - q)*n); break; } #endif @@ -663,16 +664,16 @@ ecl_ceiling2(cl_object x, cl_object y) float n = ecl_to_double(y); float p = sf(x)/n; float q = ceilf(p); - VALUES(0) = float_to_integer(q); - VALUES(1) = ecl_make_singlefloat((p - q)*n); + v0 = float_to_integer(q); + v1 = ecl_make_singlefloat((p - q)*n); break; } case t_doublefloat: { /* DF / ANY */ double n = ecl_to_double(y); double p = df(x)/n; double q = ceil(p); - VALUES(0) = double_to_integer(q); - VALUES(1) = ecl_make_doublefloat((p - q)*n); + v0 = double_to_integer(q); + v1 = ecl_make_doublefloat((p - q)*n); break; } #ifdef ECL_LONG_FLOAT @@ -680,8 +681,8 @@ ecl_ceiling2(cl_object x, cl_object y) long double n = ecl_to_long_double(y); long double p = ecl_long_float(x)/n; long double q = ceill(p); - VALUES(0) = long_double_to_integer(q); - VALUES(1) = make_longfloat((p - q)*n); + v0 = long_double_to_integer(q); + v1 = make_longfloat((p - q)*n); break; } #endif @@ -689,62 +690,62 @@ ecl_ceiling2(cl_object x, cl_object y) x = ecl_type_error(@'ceiling',"argument",x,@'real'); goto AGAIN; } - NVALUES = 2; - return VALUES(0); + @(return v0 v1) } @(defun ceiling (x &optional (y OBJNULL)) @ if (narg == 1) - ecl_ceiling1(x); + x = ecl_ceiling1(x); else - ecl_ceiling2(x, y); - returnn(VALUES(0)); + x = ecl_ceiling2(x, y); + returnn(x); @) cl_object ecl_truncate1(cl_object x) { + cl_object v0, v1; AGAIN: switch (type_of(x)) { case t_fixnum: case t_bignum: - VALUES(0) = x; - VALUES(1) = MAKE_FIXNUM(0); + v0 = x; + v1 = MAKE_FIXNUM(0); break; case t_ratio: - VALUES(0) = ecl_truncate2(x->ratio.num, x->ratio.den); - VALUES(1) = ecl_make_ratio(VALUES(1), x->ratio.den); + v0 = ecl_truncate2(x->ratio.num, x->ratio.den); + v1 = ecl_make_ratio(VALUES(1), x->ratio.den); break; #ifdef ECL_SHORT_FLOAT case t_shortfloat: { float d = ecl_short_float(x); float y = d > 0? floorf(d) : ceilf(d); - VALUES(0) = float_to_integer(y); - VALUES(1) = make_shortfloat(d - y); + v0 = float_to_integer(y); + v1 = make_shortfloat(d - y); break; } #endif case t_singlefloat: { float d = sf(x); float y = d > 0? floorf(d) : ceilf(d); - VALUES(0) = float_to_integer(y); - VALUES(1) = ecl_make_singlefloat(d - y); + v0 = float_to_integer(y); + v1 = ecl_make_singlefloat(d - y); break; } case t_doublefloat: { double d = df(x); double y = d > 0? floor(d) : ceil(d); - VALUES(0) = double_to_integer(y); - VALUES(1) = ecl_make_doublefloat(d - y); + v0 = double_to_integer(y); + v1 = ecl_make_doublefloat(d - y); break; } #ifdef ECL_LONG_FLOAT case t_longfloat: { long double d = ecl_long_float(x); long double y = d > 0? floorl(d) : ceill(d); - VALUES(0) = long_double_to_integer(y); - VALUES(1) = make_longfloat(d - y); + v0 = long_double_to_integer(y); + v1 = make_longfloat(d - y); break; } #endif @@ -752,8 +753,7 @@ ecl_truncate1(cl_object x) x = ecl_type_error(@'truncate',"argument",x,@'real'); goto AGAIN; } - NVALUES = 2; - return VALUES(0); + @(return v0 v1) } cl_object @@ -768,10 +768,10 @@ ecl_truncate2(cl_object x, cl_object y) @(defun truncate (x &optional (y OBJNULL)) @ if (narg == 1) - ecl_truncate1(x); + x = ecl_truncate1(x); else - ecl_truncate2(x, y); - returnn(VALUES(0)); + x = ecl_truncate2(x, y); + returnn(x); @) static double @@ -817,16 +817,17 @@ round_long_double(long double d) cl_object ecl_round1(cl_object x) { + cl_object v0, v1; AGAIN: switch (type_of(x)) { case t_fixnum: case t_bignum: - VALUES(0) = x; - VALUES(1) = MAKE_FIXNUM(0); + v0 = x; + v1 = MAKE_FIXNUM(0); break; case t_ratio: - VALUES(0) = ecl_round2(x->ratio.num, x->ratio.den); - VALUES(1) = ecl_make_ratio(VALUES(1), x->ratio.den); + v0 = ecl_round2(x->ratio.num, x->ratio.den); + v1 = ecl_make_ratio(VALUES(1), x->ratio.den); break; #ifdef ECL_SHORT_FLOAT case t_shortfloat: @@ -836,23 +837,23 @@ ecl_round1(cl_object x) case t_singlefloat: { float d = sf(x); float q = round_double(d); - VALUES(0) = float_to_integer(q); - VALUES(1) = ecl_make_singlefloat(d - q); + v0 = float_to_integer(q); + v1 = ecl_make_singlefloat(d - q); break; } case t_doublefloat: { double d = df(x); double q = round_double(d); - VALUES(0) = double_to_integer(q); - VALUES(1) = ecl_make_doublefloat(d - q); + v0 = double_to_integer(q); + v1 = ecl_make_doublefloat(d - q); break; } #ifdef ECL_LONG_FLOAT case t_longfloat: { long double d = ecl_long_float(x); long double q = round_long_double(d); - VALUES(0) = long_double_to_integer(q); - VALUES(1) = make_longfloat(d - q); + v0 = long_double_to_integer(q); + v1 = make_longfloat(d - q); break; } #endif @@ -860,21 +861,21 @@ ecl_round1(cl_object x) x = ecl_type_error(@'round',"argument",x,@'real'); goto AGAIN; } - NVALUES = 2; - return VALUES(0); + @(return v0 v1) } cl_object ecl_round2(cl_object x, cl_object y) { + cl_object v0, v1; cl_object q; q = ecl_divide(x, y); switch (type_of(q)) { case t_fixnum: case t_bignum: - VALUES(0) = q; - VALUES(1) = MAKE_FIXNUM(0); + v0 = q; + v1 = MAKE_FIXNUM(0); break; case t_ratio: { cl_object q1 = ecl_integer_divide(q->ratio.num, q->ratio.den); @@ -890,25 +891,24 @@ ecl_round2(cl_object x, cl_object y) q1 = ecl_one_plus(q1); } } - VALUES(0) = q1; - VALUES(1) = number_remainder(x, y, q1); + v0 = q1; + v1 = number_remainder(x, y, q1); break; } default: - VALUES(0) = q = ecl_round1(q); - VALUES(1) = number_remainder(x, y, q); + v0 = q = ecl_round1(q); + v1 = number_remainder(x, y, q); } - NVALUES = 2; - return VALUES(0); + @(return v0 v1) } @(defun round (x &optional (y OBJNULL)) @ if (narg == 1) - ecl_round1(x); + x = ecl_round1(x); else - ecl_round2(x, y); - returnn(VALUES(0)); + x = ecl_round2(x, y); + returnn(x); @) From 1813aa8e6c820ab6af2ca2bbfd6d048ba4abb752 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Sat, 28 Jun 2008 18:14:00 +0000 Subject: [PATCH 08/16] Reuse code for long function calls --- src/cmp/cmpcall.lsp | 11 +++++++---- src/cmp/cmpeval.lsp | 14 +++----------- 2 files changed, 10 insertions(+), 15 deletions(-) diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index 9a872c494..93db7bca3 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -21,14 +21,17 @@ (or (cmp-env-search-macro name) (macro-function name))) +(defun unoptimized-long-call (fun arguments) + (let ((frame (gensym))) + (c1expr `(with-stack ,frame + ,@(loop for i in arguments collect `(stack-push ,i)) + (si::apply-from-stack-frame ,frame ,fim))))) + (defun unoptimized-funcall (fun arguments) (let ((l (length arguments))) (if (<= l si::c-arguments-limit) (make-c1form* 'FUNCALL :args (c1expr fun) (c1args* arguments)) - (let ((frame (gensym))) - (c1expr `(with-stack ,frame - ,@(loop for i in arguments collect `(stack-push ,i)) - (si::apply-from-stack-frame ,frame ,fim))))))) + (unoptimized-long-call fun arguments)))) (defun c1funcall (args) (check-args-number 'FUNCALL args 1) diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index 7f8e46654..d1774fe52 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -71,13 +71,8 @@ (defun c1call-local (fname args) (let ((fun (local-function-ref fname))) (when fun - (let ((l (length args))) - (when (> l si::c-arguments-limit) - (return-from c1call-local - (let ((frame (gensym))) - (c1expr `(with-stack ,frame - ,@(loop for i in args collect `(stack-push ,i)) - (si::apply-from-stack-frame ,frame #',fname))))))) + (when (> (length args) si::c-arguments-limit) + (return-from c1call-local (unoptimized-long-call `#',fname args))) (let* ((forms (c1args* args)) (lambda-form (fun-lambda fun)) (return-type (or (get-local-return-type fun) 'T)) @@ -100,10 +95,7 @@ (let ((l (length args)) forms) (cond ((> l si::c-arguments-limit) - (c1expr (let ((frame (gensym))) - `(with-stack ,frame - ,@(loop for i in args collect `(stack-push ,frame ,i)) - (si::apply-from-stack-frame ,frame #',fname))))) + (unoptimized-long-call `#',fname args)) ((maybe-optimize-structure-access fname args)) #+clos ((maybe-optimize-generic-function fname args)) From 400b22aac5fc227b8c141baa5542b6aaf0eaecf1 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Sat, 28 Jun 2008 18:14:36 +0000 Subject: [PATCH 09/16] Remove unused field in cl_env --- src/c/main.d | 5 ----- src/h/external.h | 3 --- 2 files changed, 8 deletions(-) diff --git a/src/c/main.d b/src/c/main.d index efd968920..29ae88bff 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -71,11 +71,6 @@ ecl_init_env(struct cl_env_struct *env) env->stack_size = 0; cl_stack_set_size(16*LISP_PAGESIZE); - env->funcall_frame.t = t_frame; - env->funcall_frame.stack = 0; - env->funcall_frame.bottom = - env->funcall_frame.top = env->values; - #if !defined(ECL_CMU_FORMAT) env->print_pretty = FALSE; env->queue = cl_alloc_atomic(ECL_PPRINT_QUEUE_SIZE * sizeof(short)); diff --git a/src/h/external.h b/src/h/external.h index 4f0c8a535..f2a9de7bb 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -63,9 +63,6 @@ struct cl_env_struct { cl_index nvalues; cl_object values[ECL_MULTIPLE_VALUES_LIMIT]; - /* Stack frame used by cl_funcall() */ - struct ecl_stack_frame funcall_frame; - /* Private variables used by different parts of ECL: */ /* ... the reader ... */ cl_object string_pool; From 064df295ac0186648acf5602a73961b33bcc6e00 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Sat, 28 Jun 2008 18:14:55 +0000 Subject: [PATCH 10/16] Fixed typo --- src/cmp/cmpcall.lsp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index 93db7bca3..531fc1703 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -24,8 +24,8 @@ (defun unoptimized-long-call (fun arguments) (let ((frame (gensym))) (c1expr `(with-stack ,frame - ,@(loop for i in arguments collect `(stack-push ,i)) - (si::apply-from-stack-frame ,frame ,fim))))) + ,@(loop for i in arguments collect `(stack-push ,frame ,i)) + (si::apply-from-stack-frame ,frame ,fun))))) (defun unoptimized-funcall (fun arguments) (let ((l (length arguments))) From ac3e155a1943361a7308177e0ff8f50bdf37a578 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Sat, 28 Jun 2008 18:15:25 +0000 Subject: [PATCH 11/16] We risk a SIGBUS if we do not access a 2-bytes object using two 1-byte dereferences --- src/h/bytecodes.h | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index ff0238f17..7abf8a7ca 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -107,10 +107,7 @@ typedef int16_t cl_oparg; # ifdef WORDS_BIGENDIAN # define READ_OPARG(v) ((cl_fixnum)v[0] << 8) + (unsigned char)v[1] # else -#if 0 # define READ_OPARG(v) ((cl_fixnum)v[1] << 8) + (unsigned char)v[0] -#else -# define READ_OPARG(v) ((cl_oparg*)v)[0] #endif # endif # define GET_OPARG(r,v) { r = READ_OPARG(v); v += 2; } From 10faa8ddaf2e96c1c2c06eac5f30b22336bf36bc Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Sat, 28 Jun 2008 18:15:40 +0000 Subject: [PATCH 12/16] Make the subtypep database consistent with the gray stream classes --- src/lsp/predlib.lsp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp index 872eceb05..d8c7b9e9d 100644 --- a/src/lsp/predlib.lsp +++ b/src/lsp/predlib.lsp @@ -1089,7 +1089,8 @@ if not possible." (SYNONYM-STREAM) (TWO-WAY-STREAM) (STREAM (OR BROADCAST-STREAM CONCATENATED-STREAM ECHO-STREAM - FILE-STREAM STRING-STREAM SYNONYM-STREAM TWO-WAY-STREAM)) + FILE-STREAM STRING-STREAM SYNONYM-STREAM TWO-WAY-STREAM + #+clos-streams GRAY:FUNDAMENTAL-STREAM)) (READTABLE) #+threads (MP::PROCESS) From 89138409141e5f75161962414b920e97799f66f1 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Sat, 28 Jun 2008 18:56:18 +0000 Subject: [PATCH 13/16] Temporarily deactivate location objects --- src/c/compiler.d | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/c/compiler.d b/src/c/compiler.d index afa3e4496..07f3e4da7 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -392,12 +392,16 @@ asm_op2c(register int code, register cl_object o) { * match those of Common-Lisp. */ +#if 0 +#define new_location(x) MAKE_FIXNUM(0) +#else static cl_object new_location(cl_object name) { cl_object loc = CONS(MAKE_FIXNUM(ENV->env_depth), MAKE_FIXNUM((ENV->env_size++))); return loc; } +#endif static cl_index c_register_block(cl_object name) From 48a3053086ee2982b8efc648263c421c33a53029 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Sat, 28 Jun 2008 18:56:31 +0000 Subject: [PATCH 14/16] Remove typo --- src/h/bytecodes.h | 1 - 1 file changed, 1 deletion(-) diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index 7abf8a7ca..b3b5c5e01 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -108,7 +108,6 @@ typedef int16_t cl_oparg; # define READ_OPARG(v) ((cl_fixnum)v[0] << 8) + (unsigned char)v[1] # else # define READ_OPARG(v) ((cl_fixnum)v[1] << 8) + (unsigned char)v[0] -#endif # endif # define GET_OPARG(r,v) { r = READ_OPARG(v); v += 2; } #else From 04268a5a51aa24d2b5a815450f7d5d0858282413 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Sun, 29 Jun 2008 00:32:48 +0000 Subject: [PATCH 15/16] Speed up calling unknown functions by having a local frame that we reuse --- src/cmp/cmpcall.lsp | 15 ++++++++++++++- src/cmp/cmpenv.lsp | 1 + src/cmp/cmploc.lsp | 7 +++++++ src/cmp/cmpstack.lsp | 8 ++++++-- src/cmp/cmptop.lsp | 18 ++++++++++++++---- 5 files changed, 42 insertions(+), 7 deletions(-) diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index 531fc1703..d590188bc 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -258,7 +258,20 @@ (progn (cmpnote "Emiting FDEFINITION for ~S" fname) (setq loc (list 'FDEFINITION fname)))))) - `(CALL "funcall" (,(1+ (length args)) ,loc ,@(coerce-locs args)) ,fname)) + (do ((i 0 (1+ i)) + (l args (cdr l))) + ((endp l) + (progn + (cond ((> i *max-stack*) + (setf *max-stack* i)) + ((zerop *max-stack*) + (setf *max-stack* 1))) + (wt-nl +ecl-local-stack-frame-variable+ ".top = " + +ecl-local-stack-variable+ "+" i ";") + `(CALL "ecl_apply_from_stack_frame" ((LOCAL-FRAME NIL) ,loc) ,fname))) + (wt-nl +ecl-local-stack-variable+ "[" i "]=") + (wt-coerce-loc :object (second (first l))) + (wt ";"))) ;;; Functions that use MAYBE-SAVE-VALUE should rebind *temp*. (defun maybe-save-value (value &optional (other-forms nil other-forms-flag)) diff --git a/src/cmp/cmpenv.lsp b/src/cmp/cmpenv.lsp index 27d4403f0..b5cc935c5 100644 --- a/src/cmp/cmpenv.lsp +++ b/src/cmp/cmpenv.lsp @@ -21,6 +21,7 @@ (defun init-env () (setq *compiler-phase* 't1) (setq *callbacks* nil) + (setq *max-stack* 0) (setq *max-temp* 0) (setq *temp* 0) (setq *next-cmacro* 0) diff --git a/src/cmp/cmploc.lsp b/src/cmp/cmploc.lsp index d4572cb0a..b6bdef197 100644 --- a/src/cmp/cmploc.lsp +++ b/src/cmp/cmploc.lsp @@ -26,6 +26,7 @@ ;;; ( VV-temp vv-index ) ;;; ( LCL lcl [representation-type]) local variable, type unboxed ;;; ( TEMP temp ) local variable, type object +;;; ( FRAME ndx ) variable in local frame stack ;;; ( CALL c-fun-name args fname ) locs are locations containing the arguments ;;; ( CALL-NORMAL fun locs) similar as CALL, but number of arguments is fixed ;;; ( C-INLINE output-type fun/string locs side-effects output-var ) @@ -182,8 +183,14 @@ (defun values-loc (n) (list 'VALUE n)) +(defun wt-local-frame (n) + (if n + (wt +ecl-local-stack-variable+ "[" n "]") + (wt "((cl_object)&" +ecl-local-stack-frame-variable+ ")"))) + ;;; ----------------------------------------------------------------- +(put-sysprop 'LOCAL-FRAME 'WT-LOC #'wt-local-frame) (put-sysprop 'TEMP 'WT-LOC #'wt-temp) (put-sysprop 'LCL 'WT-LOC #'wt-lcl-loc) (put-sysprop 'VV 'WT-LOC #'wt-vv) diff --git a/src/cmp/cmpstack.lsp b/src/cmp/cmpstack.lsp index a42ac904d..ebf458515 100644 --- a/src/cmp/cmpstack.lsp +++ b/src/cmp/cmpstack.lsp @@ -22,6 +22,12 @@ (in-package "COMPILER") +(defconstant +ecl-stack-frame-variable+ "_ecl_inner_frame") + +(defconstant +ecl-local-stack-frame-variable+ "__frame") + +(defconstant +ecl-local-stack-variable+ "__frame_sp") + (defun c1with-stack (forms) (let* ((var (pop forms)) (body (c1expr `(let ((,var (innermost-stack-frame))) ,@forms)))) @@ -29,8 +35,6 @@ :type (c1form-type body) :args body))) -(defvar +ecl-stack-frame-variable+ "_ecl_inner_frame") - (defun c2with-stack (body) (let* ((new-destination (tmp-destination *destination*)) (*temp* *temp*)) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 5d64c00e0..c32fc872c 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -113,6 +113,7 @@ (wt-nl-h "#include ")) ;;; Initialization function. (let* ((*lcl* 0) (*lex* 0) (*max-lex* 0) (*max-env* 0) (*max-temp* 0) + (*max-stack* 0) (*reservation-cmacro* (next-cmacro)) (c-output-file *compiler-output1*) (*compiler-output1* (make-string-output-stream)) @@ -124,8 +125,10 @@ (wt-nl1 "extern \"C\"") (wt-nl1 "#endif") (wt-nl1 "ECL_DLLEXPORT void " name "(cl_object flag)") - (wt-nl1 "{ VT" *reservation-cmacro* " VLEX" *reservation-cmacro* - " CLSR" *reservation-cmacro*) + (wt-nl1 "{ VT" *reservation-cmacro* + " VLEX" *reservation-cmacro* + " CLSR" *reservation-cmacro* + " STCK" *reservation-cmacro*) (wt-nl "cl_object value0;") (wt-nl "cl_object *VVtemp;") (when shared-data @@ -334,7 +337,8 @@ (defun wt-function-prolog (&optional sp local-entry) (wt " VT" *reservation-cmacro* " VLEX" *reservation-cmacro* - " CLSR" *reservation-cmacro*) + " CLSR" *reservation-cmacro* + " STCK" *reservation-cmacro*) (wt-nl "cl_object value0;") (when sp (wt-nl "bds_check;")) ; (when (compiler-push-events) (wt-nl "ihs_check;")) @@ -359,6 +363,11 @@ (when (plusp *max-lex*) (wt-h " volatile cl_object lex" *level* "[" *max-lex* "];")) (wt-nl-h "#define CLSR" *reservation-cmacro*) + (wt-nl-h "#define STCK" *reservation-cmacro*) + (unless (zerop *max-stack*) + (wt-h " cl_object " +ecl-local-stack-variable+ "[" *max-stack* "]; " + "struct ecl_stack_frame " +ecl-local-stack-frame-variable+ + " = { t_frame, 0, 0, 0, " +ecl-local-stack-variable+ ", 0, 0 };")) (when (plusp *max-env*) (unless (eq closure-type 'CLOSURE) (wt-h " cl_object " *volatile* "env0;")) @@ -567,7 +576,8 @@ (wt-nl1 "{") (wt " VT" *reservation-cmacro* " VLEX" *reservation-cmacro* - " CLSR" *reservation-cmacro*) + " CLSR" *reservation-cmacro* + " STCK" *reservation-cmacro*) (wt-nl *volatile* "cl_object value0;") (when (>= (fun-debug fun) 2) (wt-nl "struct ihs_frame ihs;")) From b3fc6d3975530d3bcee5d4d72bb7ec40df650bdc Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Mon, 30 Jun 2008 19:35:58 +0000 Subject: [PATCH 16/16] _pipe() is also needed for Mingw32 --- src/c/unixsys.d | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/c/unixsys.d b/src/c/unixsys.d index 338253063..f57519d8f 100644 --- a/src/c/unixsys.d +++ b/src/c/unixsys.d @@ -53,7 +53,7 @@ si_make_pipe() { cl_object output; int fds[2], ret; -#ifdef _MSC_VER +#if defined(_MSC_VER) || defined(mingw32) ret = _pipe(fds, 4096, _O_BINARY); #else ret = pipe(fds);