sfos/ecl
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'alt-fix-513' into 'develop'

Browse source 
Fix 513 2nd try

Closes #514

See merge request embeddable-common-lisp/ecl!159
This commit is contained in:
Daniel Kochmański 2019-08-16 18:44:23 +00:00
commit 8b82c98cac
20 changed files with 105 additions and 215 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
msvc/ecl/config.h.msvc6
View file

@ -183,7 +183,7 @@ typedef unsigned char ecl_base_char;
/* Numb. of args. which can be passed using the C stack */
/* See cmplam.lsp if you change this value */
#define ECL_C_ARGUMENTS_LIMIT 64
#define ECL_C_ARGUMENTS_LIMIT 63
/* Maximum number of output arguments */
#define ECL_MULTIPLE_VALUES_LIMIT 64

7
src/c/Makefile.in
View file

@ -127,13 +127,6 @@ $(srcdir)/symbols_list2.h: $(srcdir)/symbols_list.h Makefile
# apply.o: apply.c $(HFILES)
# $(CC) $(CFLAGS) apply.c -o $@
# experimental apply (why isn't referenced anywhere?)
# apply_x86.c: $(srcdir)/arch/apply_x86.d $(DPP) $(HFILES)
# if test -f ../CROSS-DPP ; then \
# ../CROSS-DPP $(srcdir)/arch/apply_x86.d $@ ; \
# else $(DPP) $(srcdir)/arch/apply_x86.d $@ ; \
# fi
#
# These files are interrelated
#

15
src/c/apply.d
View file

@ -13,7 +13,10 @@
#include <ecl/ecl.h>
#ifndef ECL_ASM_APPLY
#if !(ECL_C_ARGUMENTS_LIMIT == 63)
#error "Please adjust code to the constant!"
#endif
cl_object
APPLY(cl_narg n, cl_objectfn fn, cl_object *x)
{
@ -651,17 +654,7 @@ APPLY_fixed(cl_narg n, cl_object (*fn)(), cl_object *x)
x[43],x[44],x[45],x[46],x[47],x[48],x[49],
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]);
case 64: return (*fn)(x[0],x[1],x[2],x[3],x[4],x[5],x[6],x[7],
x[8],x[9],x[10],x[11],x[12],x[13],x[14],
x[15],x[16],x[17],x[18],x[19],x[20],x[21],
x[22],x[23],x[24],x[25],x[26],x[27],x[28],
x[29],x[30],x[31],x[32],x[33],x[34],x[35],
x[36],x[37],x[38],x[39],x[40],x[41],x[42],
x[43],x[44],x[45],x[46],x[47],x[48],x[49],
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],x[63]);
default:
FEprogram_error("Too many arguments", 0);
}
}
#endif

103
src/c/arch/apply_x86.d
View file

@ -1,103 +0,0 @@
/* -*- 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 (x86 specific)
*
* Copyright (c) 2008 Giuseppe Attardi
*
* See file 'LICENSE' for the copyright details.
*
*/
#include <ecl/ecl.h>
cl_object
APPLY(cl_narg n, cl_objectfn fn, cl_object *x)
{
cl_object output;
asm volatile (
"movl 4(%%ebp),%%edx\n\t" /* Create a fake frame for debugger */
"pushl %%edx\n\t"
"pushl %%ebp\n\t"
"movl %%ecx, %%edx\n\t"
"cmpl $63, %%ecx\n\t" /* Copy at most 63 arguments onto the stack */
"jle FOO1\n\t"
"movl $63, %%ecx\n\t"
"FOO1:\n\t" /* Here we compute the new address of the stack pointer */
"movl %%esp, %%ebp\n\t" /* using the formula ESP = (ESP - ECX*4 - 4) & -16 */
"negl %%ecx\n\t" /* which rounds ESP making it a multiple of 16 bytes. */
"leal -4(%%esp,%%ecx,4), %%esp\n\t"
"andl $-16, %%esp\n\t"
"movl %%edx, (%%esp)\n\t" /* Then ESP[0] is the number of arguments */
"negl %%ecx\n\t"
"leal 4(%%esp), %%edi\n\t" /* and the other arguments are copied from ESP[4] on */
"rep\n\t"
"movsl\n\t"
"call *%%eax\n\t" /* At this point the stack must be aligned */
"movl %%ebp, %%esp\n\t"
"popl %%ebp\n\t"
"popl %%edx\n\t"
: "=a" (output) : "c" (n), "a" (fn), "S" (x) : "%edx", "%edi");
return output;
}
cl_object
APPLY_fixed(cl_narg n, cl_object (*fn)(), cl_object *x)
{
cl_object output;
asm volatile (
"movl 4(%%ebp),%%edx\n\t" /* Create a fake frame for debugger */
"pushl %%edx\n\t"
"pushl %%ebp\n\t"
"movl %%ecx, %%edx\n\t" /* Copy at most 63 arguments onto the stack */
"cmpl $63, %%ecx\n\t"
"jle FOO2\n\t"
"movl $63, %%ecx\n"
"FOO2:\n\t" /* Here we compute the new address of the stack pointer */
"movl %%esp, %%ebp\n\t" /* using the formula ESP = (ESP - ECX*4) & -16 */
"negl %%ecx\n\t" /* which rounds ESP making it a multiple of 16 bytes. */
"leal (%%esp,%%ecx,4), %%esp\n\t"
"andl $-16, %%esp\n\t"
"negl %%ecx\n\t"
"movl %%esp, %%edi\n\t" /* then the arguments are copied from ESP[0] on */
"rep\n\t"
"movsl\n\t"
"call *%%eax\n\t" /* At this point the stack must be aligned */
"movl %%ebp, %%esp\n\t"
"popl %%ebp\n\t"
"popl %%edx\n\t"
: "=a" (output) : "c" (n), "a" (fn), "S" (x) : "%edx", "%edi");
return output;
}
cl_object
APPLY_closure(cl_narg n, cl_objectfn fn, cl_object cl, cl_object *x)
{
cl_object output;
asm volatile (
"movl 4(%%ebp),%%edx\n\t" /* Create a fake frame for debugger */
"pushl %%edx\n\t"
"pushl %%ebp\n\t"
"movl %%ecx, %%edx\n\t"
"cmpl $63, %%ecx\n\t" /* Copy at most 63 arguments onto the stack */
"jle FOO3\n\t"
"movl $63, %%ecx\n\t"
"FOO3:\n\t" /* Here we compute the new address of the stack pointer */
"movl %%esp, %%ebp\n\t" /* using the formula ESP = (ESP - ECX*4 - 8) & -16 */
"negl %%ecx\n\t" /* which rounds ESP making it a multiple of 16 bytes. */
"leal -8(%%esp,%%ecx,4), %%esp\n\t"
"andl $-16, %%esp\n\t"
"movl %%edx, (%%esp)\n\t" /* Then ESP[0] is the number of arguments */
"movl %%edi, 4(%%esp)\n\t" /* ESP[4] is the closure environment */
"negl %%ecx\n\t"
"leal 8(%%esp), %%edi\n\t" /* and the other arguments are copied from ESP[8] on */
"rep\n\t"
"movsl\n\t"
"call *%%eax\n\t" /* At this point the stack must be aligned */
"movl %%ebp, %%esp\n\t"
"popl %%ebp\n\t"
"popl %%edx\n\t"
: "=a" (output) : "c" (n), "a" (fn), "S" (x), "D" (cl) : "%edx");
return output;
}

4
src/c/cfun_dispatch.d
View file

@ -5,6 +5,10 @@
cfun_dispatch.c - trampolines for functions
*/
#if !(ECL_C_ARGUMENTS_LIMIT == 63)
#error "Please adjust code to the constant!"
#endif
static cl_object dispatch0 (cl_narg narg) {
const cl_env_ptr the_env = ecl_process_env();
cl_object fun = the_env->function;

4
src/c/clos/gfun.d
View file

@ -223,14 +223,12 @@ _ecl_standard_dispatch(cl_object frame, cl_object gf)
* which will be wiped out by the next function call. However this only
* happens when we cannot reuse the values in the C stack.
*/
#if !defined(ECL_USE_VARARG_AS_POINTER)
struct ecl_stack_frame frame_aux;
if (frame->frame.stack == (void*)0x1) {
const cl_object new_frame = (cl_object)&frame_aux;
ECL_STACK_FRAME_COPY(new_frame, frame);
frame = new_frame;
}
#endif
ECL_WITHOUT_INTERRUPTS_BEGIN(env) {
vector = fill_spec_vector(cache->keys, frame, gf);
@ -259,10 +257,8 @@ _ecl_standard_dispatch(cl_object frame, cl_object gf)
func = _ecl_funcall3(func, frame, ECL_NIL);
/* Only need to close the copy */
#if !defined(ECL_USE_VARARG_AS_POINTER)
if (frame == (cl_object)&frame_aux)
ecl_stack_frame_close(frame);
#endif
return func;
}

28
src/c/eval.d
View file

@ -19,7 +19,7 @@
cl_object *
_ecl_va_sp(cl_narg narg)
{
return ecl_process_env()->stack_top - narg;
return ecl_process_env()->stack_frame->frame.base + narg;
}
/* Calling conventions:
@ -37,6 +37,8 @@ ecl_apply_from_stack_frame(cl_object frame, cl_object x)
cl_object *sp = frame->frame.base;
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 == OBJNULL || fun == ECL_NIL))
@ -45,37 +47,47 @@ ecl_apply_from_stack_frame(cl_object frame, cl_object x)
case t_cfunfixed:
if (ecl_unlikely(narg != (cl_index)fun->cfun.narg))
FEwrong_num_arguments(fun);
return APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp);
ret = APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp);
break;
case t_cfun:
return APPLY(narg, fun->cfun.entry, sp);
ret = APPLY(narg, fun->cfun.entry, sp);
break;
case t_cclosure:
return APPLY(narg, fun->cclosure.entry, sp);
ret = APPLY(narg, fun->cclosure.entry, sp);
break;
case t_instance:
switch (fun->instance.isgf) {
case ECL_STANDARD_DISPATCH:
case ECL_RESTRICTED_DISPATCH:
return _ecl_standard_dispatch(frame, fun);
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:
return APPLY(narg, fun->instance.entry, sp);
ret = APPLY(narg, fun->instance.entry, sp);
break;
default:
FEinvalid_function(fun);
}
break;
case t_symbol:
if (ecl_unlikely(fun->symbol.stype & ecl_stp_macro))
FEundefined_function(x);
fun = ECL_SYM_FUN(fun);
goto AGAIN;
case t_bytecodes:
return ecl_interpret(frame, ECL_NIL, fun);
ret = ecl_interpret(frame, ECL_NIL, fun);
break;
case t_bclosure:
return ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code);
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

4
src/c/interpreter.d
View file

@ -510,6 +510,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
cl_object frame = (cl_object)&frame_aux;
frame_aux.size = narg;
frame_aux.base = the_env->stack_top - narg;
the_env->stack_frame = frame;
SETUP_ENV(the_env);
AGAIN:
if (ecl_unlikely(reg0 == OBJNULL || reg0 == ECL_NIL))
@ -561,11 +562,12 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes)
FEinvalid_function(reg0);
}
ECL_STACK_POP_N_UNSAFE(the_env, narg);
the_env->stack_frame = NULL; /* for gc's sake */
THREAD_NEXT;
}
/* OP_POP
Pops a singe value pushed by a OP_PUSH* operator.
Pops a single value pushed by a OP_PUSH* operator.
*/
CASE(OP_POP); {
reg0 = ECL_STACK_POP_UNSAFE(the_env);

2
src/c/unixint.d
View file

@ -384,6 +384,7 @@ handle_all_queued_interrupt_safe(cl_env_ptr env)
cl_index nvalues = env->nvalues;
cl_object values[ECL_MULTIPLE_VALUES_LIMIT];
memcpy(values, env->values, ECL_MULTIPLE_VALUES_LIMIT*sizeof(cl_object));
cl_object stack_frame = env->stack_frame;
cl_object big_register[3];
memcpy(big_register, env->big_register, 3*sizeof(cl_object));
cl_object packages_to_be_created = env->packages_to_be_created;
@ -409,6 +410,7 @@ handle_all_queued_interrupt_safe(cl_env_ptr env)
env->packages_to_be_created_p = packages_to_be_created_p;
env->packages_to_be_created = packages_to_be_created;
memcpy(env->big_register, big_register, 3*sizeof(cl_object));
env->stack_frame = stack_frame;
memcpy(env->values, values, ECL_MULTIPLE_VALUES_LIMIT*sizeof(cl_object));
env->nvalues = nvalues;
env->function = fun;

2
src/cmp/cmpglobals.lsp
View file

@ -265,7 +265,6 @@ lines are inserted, but the order is preserved")
(defvar *global-funs* nil) ; holds { fun }*
(defvar *use-c-global* nil) ; honor si::c-global declaration
(defvar *global-cfuns-array* nil) ; holds { fun }*
(defvar *linking-calls* nil) ; holds { ( global-fun-name fun symbol c-fun-name var-name ) }*
(defvar *local-funs* nil) ; holds { fun }*
(defvar *top-level-forms* nil) ; holds { top-level-form }*
(defvar *make-forms* nil) ; holds { top-level-form }*
@ -324,7 +323,6 @@ be deleted if they have been opened with LoadLibrary.")
(*global-vars* nil)
(*global-funs* nil)
(*global-cfuns-array* nil)
(*linking-calls* nil)
(*global-entries* nil)
(*undefined-vars* nil)
(*top-level-forms* nil)

2
src/cmp/cmplam.lsp
View file

@ -429,7 +429,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
(format nil "lex~D" (1- *level*)))
(t "narg"))))
(if (setq simple-varargs (and (not (or rest keywords allow-other-keys))
(< (+ nreq nopt) 30)))
(<= (+ nreq nopt) si::c-arguments-limit)))
(wt-nl "va_list args; va_start(args,"
(last-variable)
");")

3
src/cmp/cmpmulti.lsp
View file

@ -46,8 +46,7 @@
`(with-stack ,frame
(stack-push-values ,frame ,(first args))
,@(rest args)
(stack-pop ,frame))))
)
(stack-pop ,frame)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

33
src/cmp/cmptop.lsp
View file

@ -56,8 +56,7 @@
((setq fd (cmp-macro-function fun))
(push 'macroexpand *current-toplevel-form*)
(t1expr* (cmp-expand-macro fd form)))
(t (t1ordinary form))
))))
(t (t1ordinary form))))))
(defun t1/c1expr (form)
(cond ((not *compile-toplevel*)
@ -200,34 +199,10 @@
(wt-nl-h "#define VM " (data-permanent-storage-size))
(wt-nl-h "#define VMtemp " (data-temporary-storage-size)))))
(dolist (l *linking-calls*)
(let* ((c-name (fourth l))
(var-name (fifth l)))
(wt-nl-h "static cl_object " c-name "(cl_narg, ...);")
(wt-nl-h "static cl_object (*" var-name ")(cl_narg, ...)=" c-name ";")))
;;; Global entries for directly called functions.
(dolist (x *global-entries*)
(apply 'wt-global-entry x))
;;; Initial functions for linking calls.
(dolist (l *linking-calls*)
(let* ((var-name (fifth l))
(c-name (fourth l))
(lisp-name (third l)))
(wt-nl "static cl_object " c-name "(cl_narg narg, ...)"
"{TRAMPOLINK(narg," lisp-name ",&" var-name ",Cblock);}")))
#+(or)
(wt-nl-h "static cl_object ECL_SETF_DEFINITION(cl_object setf_vv, cl_object setf_form)
{
cl_object f1 = ecl_fdefinition(setf_form);
cl_object f2 = ECL_CONS_CAR(setf_vv);
if (f1 != f2) {
FEundefined_function(setf_form);
}
return f2;
}
")
(wt-nl-h "#define ECL_DEFINE_SETF_FUNCTIONS ")
(loop for (name setf-vv name-vv) in *setf-definitions*
do (wt-h #\\ #\Newline setf-vv "=ecl_setf_definition(" name-vv ",ECL_T);"))
@ -727,8 +702,10 @@
(lambda-expr (fun-lambda fun))
(volatile (c1form-volatile* lambda-expr))
(lambda-list (c1form-arg 0 lambda-expr))
(requireds (mapcar #'(lambda (v) (next-lcl (var-name v)))
(car lambda-list)))
(requireds (loop
repeat si::c-arguments-limit
for arg in (car lambda-list)
collect (next-lcl (var-name arg))))
(narg (fun-needs-narg fun)))
(let ((cmp-env (c1form-env lambda-expr)))
(wt-comment-nl "optimize speed ~D, debug ~D, space ~D, safety ~D "

16
src/configure vendored
View file

@ -740,6 +740,7 @@ infodir
docdir
oldincludedir
includedir
runstatedir
localstatedir
sharedstatedir
sysconfdir
@ -865,6 +866,7 @@ datadir='${datarootdir}'
sysconfdir='${prefix}/etc'
sharedstatedir='${prefix}/com'
localstatedir='${prefix}/var'
runstatedir='${localstatedir}/run'
includedir='${prefix}/include'
oldincludedir='/usr/include'
docdir='${datarootdir}/doc/${PACKAGE_TARNAME}'
@ -1117,6 +1119,15 @@ do
| -silent | --silent | --silen | --sile | --sil)
silent=yes ;;
-runstatedir | --runstatedir | --runstatedi | --runstated \
| --runstate | --runstat | --runsta | --runst | --runs \
| --run | --ru | --r)
ac_prev=runstatedir ;;
-runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \
| --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \
| --run=* | --ru=* | --r=*)
runstatedir=$ac_optarg ;;
-sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
ac_prev=sbindir ;;
-sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
@ -1254,7 +1265,7 @@ fi
for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \
datadir sysconfdir sharedstatedir localstatedir includedir \
oldincludedir docdir infodir htmldir dvidir pdfdir psdir \
libdir localedir mandir
libdir localedir mandir runstatedir
do
eval ac_val=\$$ac_var
# Remove trailing slashes.
@ -1407,6 +1418,7 @@ Fine tuning of the installation directories:
--sysconfdir=DIR read-only single-machine data [PREFIX/etc]
--sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com]
--localstatedir=DIR modifiable single-machine data [PREFIX/var]
--runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run]
--libdir=DIR object code libraries [EPREFIX/lib]
--includedir=DIR C header files [PREFIX/include]
--oldincludedir=DIR C header files for non-gcc [/usr/include]
@ -8995,6 +9007,8 @@ main ()
if (*(data + i) != *(data3 + i))
return 14;
close (fd);
free (data);
free (data3);
return 0;
}
_ACEOF

5
src/h/config-internal.h.in
View file

@ -31,9 +31,6 @@
/* Undefine this if you do not want ECL to check for circular lists */
#define ECL_SAFE
/* Assembler implementation of APPLY and friends */
#undef ECL_ASM_APPLY
/* Activate Boehm-Weiser incremental garbage collector */
#undef GBC_BOEHM_GENGC
@ -52,8 +49,6 @@
* SYSTEM FEATURES:
*/
/* Argument list can be access as an array */
#undef ECL_USE_VARARG_AS_POINTER
/* Most significant byte first */
#undef WORDS_BIGENDIAN
/* Has <sys/resource.h> */

4
src/h/ecl-cmp.h
View file

@ -34,10 +34,6 @@
#include <math.h> /* for inline mathematics */
#include <ecl/ecl-inl.h>
#define TRAMPOLINK(narg, vv, lk, cblock) \
ecl_va_list args; ecl_va_start(args, narg, narg, 0); \
return(_ecl_link_call(vv, (cl_objectfn *)lk, cblock, narg, args))
enum ecl_locative_type {
_ecl_object_loc = 0,
_ecl_fixnum_loc,

3
src/h/external.h
View file

@ -26,6 +26,9 @@ struct cl_env_struct {
/* Environment for calling closures, CLOS generic functions, etc */
cl_object function;
/* Current stack frame */
cl_object stack_frame;
/* The four stacks in ECL. */
/*

37
src/h/internal.h
View file

@ -166,17 +166,6 @@ extern cl_object si_constant_form_value _ECL_ARGS((cl_narg narg, cl_object form,
struct ecl_stack_frame frame;\
cl_object name = ecl_stack_frame_open(env, (cl_object)&frame, 0);
#ifdef ECL_USE_VARARG_AS_POINTER
#define ECL_STACK_FRAME_FROM_VA_LIST(e,f,va) do { \
const cl_object __frame = (f); \
__frame->frame.t = t_frame; \
__frame->frame.stack = 0; \
__frame->frame.env = (e); \
__frame->frame.size = va[0].narg; \
__frame->frame.base = va[0].sp? va[0].sp : \
(cl_object*)va[0].args; \
} while(0)
#else
#define ECL_STACK_FRAME_FROM_VA_LIST(e,f,va) do { \
const cl_object __frame = (f); \
cl_index i, __nargs = va[0].narg; \
@ -185,36 +174,15 @@ extern cl_object si_constant_form_value _ECL_ARGS((cl_narg narg, cl_object form,
__frame->frame.base[i] = ecl_va_arg(va); \
} \
} while (0)
#endif
#ifdef ECL_USE_VARARG_AS_POINTER
#define ECL_STACK_FRAME_VARARGS_BEGIN(narg,lastarg,frame) \
struct ecl_frame __ecl_frame; \
const cl_object frame = (cl_object)&__ecl_frame; \
const cl_env_ptr env = ecl_process_env(); \
frame->frame.t = t_frame; \
frame->frame.stack = 0; \
frame->frame.env = env; \
frame->frame.size = narg; \
if (narg < ECL_C_ARGUMENTS_LIMIT) { \
va_list args; \
va_start(args, lastarg); \
frame->frame.base = (cl_object*)args; \
va_end(args); \
} else { \
frame->frame.base = env->stack_top - narg; \
}
#define ECL_STACK_FRAME_VARARGS_END(frame) \
/* No stack consumed, no need to close frame */
#else
#define ECL_STACK_FRAME_VARARGS_BEGIN(narg,lastarg,frame) \
struct ecl_frame __ecl_frame; \
struct ecl_stack_frame __ecl_frame; \
const cl_object frame = (cl_object)&__ecl_frame; \
const cl_env_ptr env = ecl_process_env(); \
frame->frame.t = t_frame; \
frame->frame.env = env; \
frame->frame.size = narg; \
if (narg < ECL_C_ARGUMENTS_LIMIT) { \
if (narg <= ECL_C_ARGUMENTS_LIMIT) { \
cl_object *p = frame->frame.base = env->values; \
va_list args; \
va_start(args, lastarg); \
@ -230,7 +198,6 @@ extern cl_object si_constant_form_value _ECL_ARGS((cl_narg narg, cl_object form,
}
#define ECL_STACK_FRAME_VARARGS_END(frame) \
/* No stack consumed, no need to close frame */
#endif
extern cl_object _ecl_bytecodes_dispatch_vararg(cl_narg narg, ...);
extern cl_object _ecl_bclosure_dispatch_vararg(cl_narg narg, ...);

4
src/h/stacks.h
View file

@ -299,7 +299,7 @@ typedef struct ecl_frame {
jmp_buf frs_jmpbuf;
cl_object frs_val;
cl_index frs_bds_top_index;
ecl_ihs_ptr frs_ihs;
ecl_ihs_ptr frs_ihs;
cl_index frs_sp;
} *ecl_frame_ptr;
@ -340,7 +340,7 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr);
#define ecl_va_start(a,p,n,k) { \
a[0].narg = (n)-(k); \
va_start(a[0].args,p); \
a[0].sp = ((n) <= ECL_C_ARGUMENTS_LIMIT)? 0 : _ecl_va_sp(a[0].narg); }
a[0].sp = ((n) <= ECL_C_ARGUMENTS_LIMIT)? 0 : _ecl_va_sp(k); }
#define ecl_va_arg(a) \
(a[0].narg--,(a[0].sp? *(a[0].sp++) : va_arg(a[0].args,cl_object)))
#define ecl_va_copy(dest,orig) { \

42
src/tests/normal-tests/compiler.lsp
View file

@ -1540,3 +1540,45 @@
(finishes (setq f2 (compile nil '(lambda () (truncate 2 1)))))
(is (equal '(0 . 0) (funcall f1)))
(is (equal '(2 0) (multiple-value-list (funcall f2))))))
;;; Date 2019-07-02
;;; URL: https://gitlab.com/embeddable-common-lisp/ecl/issues/513
;;; Description
;;;
;;; When number of args in unoptimized long call is exactly
;;; ECL_C_ARGUMENTS limit we have a segfault, when it is greater
;;; parse_key signals a condition.
(test cmp.0073.c-arguments-limit.miscompilation
(with-compiler ("aux-cmp-0073.lsp" :load t)
`(progn
(defclass modual-bleh ()
((xxx :initarg :foo :initform nil)))
(defmethod shared-initialize :after
((instance modual-bleh) (slot-names t) &key)
42)
(defun run-1 ()
">=63 arguments parse-key problem (first :foo is eaten)."
(make-instance
'modual-bleh
:foo 00 :foo 01 :foo 02 :foo 03 :foo 04 :foo 05 :foo 06 :foo 07 :foo 08 :foo 09
:foo 10 :foo 11 :foo 12 :foo 13 :foo 14 :foo 15 :foo 16 :foo 17 :foo 18 :foo 19
:foo 20 :foo 21 :foo 22 :foo 23 :foo 24 :foo 25 :foo 26 :foo 27 :foo 28 :foo 29
:foo 30 :foo 31))
(defun run-2 ()
"=62 arguments segmentation fault."
(make-instance
'modual-bleh
:foo 00 :foo 01 :foo 02 :foo 03 :foo 04 :foo 05 :foo 06 :foo 07 :foo 08 :foo 09
:foo 10 :foo 11 :foo 12 :foo 13 :foo 14 :foo 15 :foo 16 :foo 17 :foo 18 :foo 19
:foo 20 :foo 21 :foo 22 :foo 23 :foo 24 :foo 25 :foo 26 :foo 27 :foo 28 :foo 29
:foo 30))
(defun run-3 ()
"<=61 arguments all fine."
(make-instance
'modual-bleh
:foo 00 :foo 01 :foo 02 :foo 03 :foo 04 :foo 05 :foo 06 :foo 07 :foo 08 :foo 09
:foo 10 :foo 11 :foo 12 :foo 13 :foo 14 :foo 15 :foo 16 :foo 17 :foo 18 :foo 19
:foo 20 :foo 21 :foo 22 :foo 23 :foo 24 :foo 25 :foo 26 :foo 27 :foo 28 :foo 29))))
(finishes (run-1))
(finishes (run-2))
(finishes (run-3)))