mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-20 11:32:35 -08:00
Code Issues Projects Releases Packages Wiki Activity

Some functions now take a cl_env_ptr argument, becoming better isolated.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2008-10-11 22:32:54 +02:00
parent e0100efe51
commit 7c5ab4f1fb
27 changed files with 170 additions and 150 deletions
Download patch file Download diff file Expand all files Collapse all files

3
src/c/arch/ffi_x86.d
View file

@ -116,8 +116,9 @@ ecl_dynamic_callback_execute(cl_object cbk_info, char *arg_buffer)
cl_index i, size;
union ecl_ffi_values output;
enum ecl_ffi_tag tag;
cl_env_ptr env = ecl_process_env();
ECL_BUILD_STACK_FRAME(frame, aux);
ECL_BUILD_STACK_FRAME(env, frame, aux);
fun = CAR(cbk_info);
rtype = CADR(cbk_info);

3
src/c/arch/ffi_x86_64.d
View file

@ -165,8 +165,9 @@ ecl_dynamic_callback_execute(long i1, long i2, long i3, long i4, long i5, long i
enum ecl_ffi_tag tag;
long i_reg[MAX_INT_REGISTERS];
double f_reg[MAX_FP_REGISTERS];
cl_env_ptr env = ecl_process_env();
ECL_BUILD_STACK_FRAME(frame, aux);
ECL_BUILD_STACK_FRAME(env, frame, aux);
fun = CAR(cbk_info);
rtype = CADR(cbk_info);

12
src/c/compiler.d
View file

@ -59,12 +59,12 @@
/********************* PRIVATE ********************/
#define asm_begin() cl_stack_index()
#define asm_clear(h) cl_stack_set_index(h)
#define current_pc() cl_stack_index()
#define set_pc(n) cl_stack_set_index(n)
#define asm_op(o) cl_stack_push((cl_object)((cl_fixnum)(o)))
#define asm_ref(n) (cl_fixnum)(cl_env.stack[n])
#define asm_begin() ecl_stack_index(ecl_process_env())
#define asm_clear(h) ecl_stack_set_index(ecl_process_env(), h)
#define current_pc() ecl_stack_index(ecl_process_env())
#define set_pc(n) ecl_stack_set_index(ecl_process_env(), n)
#define asm_op(o) ecl_stack_push(ecl_process_env(), (cl_object)((cl_fixnum)(o)))
#define asm_ref(n) (cl_fixnum)(ecl_process_env()->stack[n])
static void asm_op2(int op, int arg);
static cl_object asm_end(cl_index handle);
static cl_index asm_jmp(register int op);

2
src/c/dpp.c
View file

@ -636,6 +636,8 @@ put_declaration(void)
int i;
int simple_varargs;
put_lineno();
fprintf(out, "\tconst cl_env_ptr the_env = ecl_process_env();\n");
for (i = 0; i < nopt; i++) {
put_lineno();
fprintf(out, "\tcl_object %s;\n", optional[i].o_var);

5
src/c/eval.d
View file

@ -28,6 +28,7 @@ _ecl_va_sp(cl_narg narg)
static cl_object
build_funcall_frame(cl_object f, cl_va_list args)
{
cl_env_ptr env = ecl_process_env();
cl_index n = args[0].narg;
cl_object *p = args[0].sp;
f->frame.stack = 0;
@ -46,6 +47,7 @@ build_funcall_frame(cl_object f, cl_va_list args)
f->frame.bottom = p;
f->frame.top = p + n;
f->frame.t = t_frame;
f->frame.env = env;
return f;
}
@ -210,7 +212,8 @@ si_unlink_symbol(cl_object s)
cl_object out;
cl_index i;
struct ecl_stack_frame frame_aux;
const cl_object frame = ecl_stack_frame_open((cl_object)&frame_aux,
const cl_object frame = ecl_stack_frame_open(ecl_process_env(),
(cl_object)&frame_aux,
narg -= 2);
for (i = 0; i < narg; i++) {
ecl_stack_frame_elt_set(frame, i, lastarg);

170
src/c/interpreter.d
View file

@ -23,9 +23,9 @@
/* -------------------- INTERPRETER STACK -------------------- */
void
cl_stack_set_size(cl_index tentative_new_size)
ecl_stack_set_size(cl_env_ptr env, cl_index tentative_new_size)
{
cl_index top = cl_env.stack_top - cl_env.stack;
cl_index top = env->stack_top - env->stack;
cl_object *new_stack, *old_stack;
cl_index safety_area = ecl_get_option(ECL_OPT_LISP_STACK_SAFETY_AREA);
cl_index new_size = tentative_new_size + 2*safety_area;
@ -33,16 +33,16 @@ cl_stack_set_size(cl_index tentative_new_size)
if (top > new_size)
FEerror("Internal error: cannot shrink stack that much.",0);
old_stack = cl_env.stack;
old_stack = env->stack;
new_stack = (cl_object *)ecl_alloc_atomic(new_size * sizeof(cl_object));
ecl_disable_interrupts();
memcpy(new_stack, old_stack, cl_env.stack_size * sizeof(cl_object));
cl_env.stack_size = new_size;
cl_env.stack = new_stack;
cl_env.stack_top = cl_env.stack + top;
cl_env.stack_limit = cl_env.stack + (new_size - 2*safety_area);
ecl_enable_interrupts();
ecl_disable_interrupts_env(env);
memcpy(new_stack, old_stack, env->stack_size * sizeof(cl_object));
env->stack_size = new_size;
env->stack = new_stack;
env->stack_top = env->stack + top;
env->stack_limit = env->stack + (new_size - 2*safety_area);
ecl_enable_interrupts_env(env);
cl_dealloc(old_stack);
@ -50,67 +50,67 @@ cl_stack_set_size(cl_index tentative_new_size)
* and friends, which take a sp=0 to have no arguments.
*/
if (top == 0)
cl_stack_push(MAKE_FIXNUM(0));
ecl_stack_push(env, MAKE_FIXNUM(0));
}
static void
cl_stack_grow(void)
ecl_stack_grow(cl_env_ptr env)
{
cl_stack_set_size(cl_env.stack_size + LISP_PAGESIZE);
ecl_stack_set_size(env, env->stack_size + env->stack_size / 2);
}
void
cl_stack_push(cl_object x) {
if (cl_env.stack_top >= cl_env.stack_limit)
cl_stack_grow();
*(cl_env.stack_top++) = x;
ecl_stack_push(cl_env_ptr env, cl_object x) {
if (env->stack_top >= env->stack_limit)
ecl_stack_grow(env);
*(env->stack_top++) = x;
}
cl_object
cl_stack_pop() {
if (cl_env.stack_top == cl_env.stack)
ecl_stack_pop(cl_env_ptr env) {
if (env->stack_top == env->stack)
FEerror("Internal error: stack underflow.",0);
return *(--cl_env.stack_top);
return *(--env->stack_top);
}
cl_index
cl_stack_index() {
return cl_env.stack_top - cl_env.stack;
ecl_stack_index(cl_env_ptr env) {
return env->stack_top - env->stack;
}
void
cl_stack_set_index(cl_index index) {
cl_object *new_top = cl_env.stack + index;
if (new_top > cl_env.stack_top)
ecl_stack_set_index(cl_env_ptr env, cl_index index) {
cl_object *new_top = env->stack + index;
if (new_top > env->stack_top)
FEerror("Internal error: tried to advance stack.",0);
cl_env.stack_top = new_top;
env->stack_top = new_top;
}
void
cl_stack_pop_n(cl_index index) {
cl_object *new_top = cl_env.stack_top - index;
if (new_top < cl_env.stack)
ecl_stack_pop_n(cl_env_ptr env, cl_index index) {
cl_object *new_top = env->stack_top - index;
if (new_top < env->stack)
FEerror("Internal error: stack underflow.",0);
cl_env.stack_top = new_top;
env->stack_top = new_top;
}
cl_index
cl_stack_push_values(void) {
ecl_stack_push_values(cl_env_ptr env) {
cl_index i;
for (i=0; i<NVALUES; i++)
cl_stack_push(VALUES(i));
for (i=0; i < env->nvalues; i++)
ecl_stack_push(env, env->values[i]);
return i;
}
void
cl_stack_pop_values(cl_index n) {
NVALUES = n;
ecl_stack_pop_values(cl_env_ptr env, cl_index n) {
env->nvalues = n;
while (n > 0)
VALUES(--n) = cl_stack_pop();
env->values[--n] = ecl_stack_pop(env);
}
cl_index
cl_stack_push_list(cl_object list)
ecl_stack_push_list(cl_env_ptr env, cl_object list)
{
cl_index n;
cl_object fast, slow;
@ -118,9 +118,9 @@ cl_stack_push_list(cl_object list)
/* INV: A list's length always fits in a fixnum */
fast = slow = list;
for (n = 0; CONSP(fast); n++, fast = CDR(fast)) {
*cl_env.stack_top = CAR(fast);
if (++cl_env.stack_top >= cl_env.stack_limit)
cl_stack_grow();
*env->stack_top = CAR(fast);
if (++env->stack_top >= env->stack_limit)
ecl_stack_grow(env);
if (n & 1) {
/* Circular list? */
if (slow == fast) break;
@ -133,20 +133,21 @@ cl_stack_push_list(cl_object list)
}
cl_object
ecl_stack_frame_open(cl_object f, cl_index size)
ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size)
{
cl_object *top = cl_env.stack_top;
cl_object *top = env->stack_top;
if (size) {
if (cl_env.stack_limit - top < size) {
if (env->stack_limit - top < size) {
cl_index delta = (size + (LISP_PAGESIZE-1))/LISP_PAGESIZE;
cl_stack_set_size(cl_env.stack_size + delta * LISP_PAGESIZE);
top = cl_env.stack_top;
ecl_stack_set_size(env, env->stack_size + delta * LISP_PAGESIZE);
top = env->stack_top;
}
}
f->frame.t = t_frame;
f->frame.stack = cl_env.stack;
f->frame.stack = env->stack;
f->frame.bottom = top;
cl_env.stack_top = f->frame.top = (top + size);
f->frame.env = env;
env->stack_top = f->frame.top = (top + size);
return f;
}
@ -154,56 +155,59 @@ void
ecl_stack_frame_enlarge(cl_object f, cl_index size)
{
cl_object *top;
cl_env_ptr env = f->frame.env;
if (f->frame.stack == 0) {
ecl_internal_error("Inconsistency in interpreter stack frame");
}
top = cl_env.stack_top;
if ((cl_env.stack_limit - top) < size) {
top = env->stack_top;
if ((env->stack_limit - top) < size) {
cl_index delta = (size + (LISP_PAGESIZE-1))/LISP_PAGESIZE;
cl_stack_set_size(cl_env.stack_size + delta * LISP_PAGESIZE);
f->frame.bottom = (f->frame.bottom - f->frame.stack) + cl_env.stack;
f->frame.stack = cl_env.stack;
top = cl_env.stack_top;
ecl_stack_set_size(env, env->stack_size + delta * LISP_PAGESIZE);
f->frame.bottom = (f->frame.bottom - f->frame.stack) + env->stack;
f->frame.stack = env->stack;
top = env->stack_top;
} else if (top != f->frame.top) {
f->frame.bottom = (f->frame.bottom - f->frame.stack) + cl_env.stack;
f->frame.stack = cl_env.stack;
top = cl_env.stack_top;
f->frame.bottom = (f->frame.bottom - f->frame.stack) + env->stack;
f->frame.stack = env->stack;
top = env->stack_top;
}
cl_env.stack_top = f->frame.top = (top + size);
env->stack_top = f->frame.top = (top + size);
}
void
ecl_stack_frame_push(cl_object f, cl_object o)
{
cl_object *top;
cl_env_ptr env = f->frame.env;
if (f->frame.stack == 0) {
ecl_internal_error("Inconsistency in interpreter stack frame");
}
top = cl_env.stack_top;
if (top >= cl_env.stack_limit) {
cl_stack_grow();
f->frame.bottom = (f->frame.bottom - f->frame.stack) + cl_env.stack;
f->frame.stack = cl_env.stack;
top = cl_env.stack_top;
top = env->stack_top;
if (top >= env->stack_limit) {
ecl_stack_grow(env);
f->frame.bottom = (f->frame.bottom - f->frame.stack) + env->stack;
f->frame.stack = env->stack;
top = env->stack_top;
} else if (top != f->frame.top) {
f->frame.bottom = (f->frame.bottom - f->frame.stack) + cl_env.stack;
f->frame.stack = cl_env.stack;
top = cl_env.stack_top;
f->frame.bottom = (f->frame.bottom - f->frame.stack) + env->stack;
f->frame.stack = env->stack;
top = env->stack_top;
}
*(top++) = o;
cl_env.stack_top = f->frame.top = top;
env->stack_top = f->frame.top = top;
}
void
ecl_stack_frame_push_values(cl_object f)
{
cl_env_ptr env = f->frame.env;
if (f->frame.stack == 0) {
ecl_internal_error("Inconsistency in interpreter stack frame");
}
cl_stack_push_values();
f->frame.bottom = (f->frame.bottom - f->frame.stack) + cl_env.stack;
f->frame.stack = cl_env.stack;
f->frame.top = cl_env.stack_top;
ecl_stack_push_values(env);
f->frame.bottom = (f->frame.bottom - f->frame.stack) + env->stack;
f->frame.stack = env->stack;
f->frame.top = env->stack_top;
}
cl_object
@ -237,10 +241,10 @@ ecl_stack_frame_elt_set(cl_object f, cl_index ndx, cl_object o)
}
cl_object
ecl_stack_frame_from_va_list(cl_object frame, cl_va_list args)
ecl_stack_frame_from_va_list(cl_env_ptr env, cl_object frame, cl_va_list args)
{
cl_index nargs = args[0].narg;
ecl_stack_frame_open(frame, nargs);
ecl_stack_frame_open(env, frame, nargs);
while (nargs) {
*(frame->frame.top-nargs) = cl_va_arg(args);
nargs--;
@ -252,7 +256,7 @@ void
ecl_stack_frame_close(cl_object f)
{
if (f->frame.stack) {
cl_stack_set_index(f->frame.bottom - f->frame.stack);
ecl_stack_set_index(f->frame.env, f->frame.bottom - f->frame.stack);
}
}
@ -260,7 +264,7 @@ cl_object
ecl_stack_frame_copy(cl_object dest, cl_object orig)
{
cl_index size = orig->frame.top - orig->frame.bottom;
dest = ecl_stack_frame_open(dest, size);
dest = ecl_stack_frame_open(orig->frame.env, dest, size);
memcpy(dest->frame.bottom, orig->frame.bottom, size * sizeof(cl_object));
return dest;
}
@ -456,7 +460,7 @@ close_around(cl_object fun, cl_object lex) {
#define STACK_PUSH(the_env,x) { \
cl_object __aux = (x); \
if (the_env->stack_top == the_env->stack_limit) { \
cl_stack_grow(); \
ecl_stack_grow(the_env); \
} \
*(the_env->stack_top++) = __aux; }
@ -465,7 +469,7 @@ close_around(cl_object fun, cl_object lex) {
#define STACK_PUSH_N(the_env,n) { \
cl_index __aux = (n); \
while ((the_env->stack_limit - the_env->stack_top) <= __aux) { \
cl_stack_grow(); \
ecl_stack_grow(the_env); \
} \
the_env->stack_top += __aux; }
@ -499,8 +503,8 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs
{
ECL_OFFSET_TABLE
typedef struct cl_env_struct *cl_env_ptr;
const cl_env_ptr the_env = &cl_env;
volatile cl_index old_bds_top_index = cl_env.bds_top - cl_env.bds_org;
const cl_env_ptr the_env = ecl_process_env();
volatile cl_index old_bds_top_index = the_env->bds_top - the_env->bds_org;
cl_opcode *vector = (cl_opcode*)bytecodes->bytecodes.code + offset;
cl_object *data = bytecodes->bytecodes.data;
cl_object reg0, reg1, lex_env = env;
@ -1347,7 +1351,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs
GET_DATA(form, vector, data);
SETUP_ENV(the_env);
the_env->values[0] = reg0;
n = cl_stack_push_values();
n = ecl_stack_push_values(the_env);
if (a == Ct) {
/* We are stepping in, but must first ask the user
* what to do. */
@ -1364,7 +1368,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs
/* We are not inside a STEP form. This should
* actually never happen. */
}
cl_stack_pop_values(n);
ecl_stack_pop_values(the_env, n);
reg0 = the_env->values[0];
THREAD_NEXT;
}
@ -1386,7 +1390,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs
cl_index n;
SETUP_ENV(the_env);
the_env->values[0] = reg0;
n = cl_stack_push_values();
n = ecl_stack_push_values(the_env);
if (a == Ct) {
/* We exit one stepping level */
ECL_SETQ(@'si::*step-level*',
@ -1400,7 +1404,7 @@ ecl_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offs
} else {
/* Not stepping, nothing to be done. */
}
cl_stack_pop_values(n);
ecl_stack_pop_values(the_env, n);
reg0 = the_env->values[0];
THREAD_NEXT;
}

2
src/c/main.d
View file

@ -120,7 +120,7 @@ ecl_init_env(cl_env_ptr env)
env->stack_top = NULL;
env->stack_limit = NULL;
env->stack_size = 0;
cl_stack_set_size(ecl_get_option(ECL_OPT_LISP_STACK_SIZE));
ecl_stack_set_size(env, ecl_get_option(ECL_OPT_LISP_STACK_SIZE));
#if !defined(ECL_CMU_FORMAT)
env->print_pretty = FALSE;

3
src/c/mapfun.d
View file

@ -22,7 +22,8 @@
struct ecl_stack_frame cdrs_frame_aux, cars_frame_aux; \
cl_object cdrs_frame, cars_frame; \
cl_index nargs; \
cdrs_frame = ecl_stack_frame_from_va_list((cl_object)&cdrs_frame_aux, list); \
cdrs_frame = ecl_stack_frame_from_va_list(ecl_process_env(),\
(cl_object)&cdrs_frame_aux, list); \
cars_frame = ecl_stack_frame_copy((cl_object)&cars_frame_aux, cdrs_frame); \
nargs = ECL_STACK_FRAME_SIZE(cars_frame); \
if (nargs == 0) { \

11
src/c/read.d
View file

@ -925,9 +925,10 @@ sharp_left_parenthesis_reader(cl_object in, cl_object c, cl_object d)
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_object last, elt, x;
cl_index dim, dimcount, i;
cl_index sp = cl_stack_index();
cl_object rtbl = ecl_current_readtable();
enum ecl_chattrib a;
@ -950,7 +951,7 @@ sharp_asterisk_reader(cl_object in, cl_object c, cl_object d)
FEreader_error("Character ~:C is not allowed after #*",
in, 1, CODE_CHAR(x));
}
cl_stack_push(MAKE_FIXNUM(x == '1'));
ecl_stack_push(env, MAKE_FIXNUM(x == '1'));
}
if (Null(d)) {
dim = dimcount;
@ -960,17 +961,17 @@ sharp_asterisk_reader(cl_object in, cl_object c, cl_object d)
FEreader_error("Too many elements in #*....", in, 0);
if (dim && (dimcount == 0))
FEreader_error("Cannot fill the bit-vector #*.", in, 0);
else last = cl_env.stack_top[-1];
else last = env->stack_top[-1];
}
x = ecl_alloc_simple_vector(dim, aet_bit);
for (i = 0; i < dim; i++) {
elt = (i < dimcount) ? cl_env.stack[sp+i] : last;
elt = (i < dimcount) ? env->stack[sp+i] : last;
if (elt == 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;
}
cl_stack_pop_n(dimcount);
ecl_stack_pop_n(env, dimcount);
@(return x)
}

6
src/c/stacks.d
View file

@ -409,7 +409,7 @@ _frs_push(register cl_object val)
output->frs_bds_top_index = env->bds_top - env->bds_org;
output->frs_val = val;
output->frs_ihs = env->ihs_top;
output->frs_sp = cl_stack_index();
output->frs_sp = ecl_stack_index(env);
return output;
}
@ -422,7 +422,7 @@ ecl_unwind(ecl_frame_ptr fr)
--env->frs_top;
env->ihs_top = env->frs_top->frs_ihs;
bds_unwind(env->frs_top->frs_bds_top_index);
cl_stack_set_index(env->frs_top->frs_sp);
ecl_stack_set_index(env, env->frs_top->frs_sp);
ecl_longjmp(env->frs_top->frs_jmpbuf, 1);
/* never reached */
}
@ -501,7 +501,7 @@ si_set_stack_size(cl_object type, cl_object size)
} else if (type == @'ext::c-stack') {
cs_set_size(env, the_size);
} else {
cl_stack_set_size(the_size);
ecl_stack_set_size(env, the_size);
}
@(return)
}

4
src/c/string.d
View file

@ -944,14 +944,14 @@ nstring_case(cl_narg narg, cl_object fun, int (*casefun)(int, bool *), cl_va_lis
for (i = 0, l = 0; i < narg; i++) {
cl_object s = si_coerce_to_base_string(cl_va_arg(args));
if (s->base_string.fillp) {
cl_stack_push(s);
ecl_stack_push(the_env, s);
l += s->base_string.fillp;
}
}
/* Do actual copying by recovering those strings */
output = cl_alloc_simple_base_string(l);
while (l) {
cl_object s = cl_stack_pop();
cl_object s = ecl_stack_pop(the_env);
size_t bytes = s->base_string.fillp;
l -= bytes;
memcpy(output->base_string.self + l, s->base_string.self, bytes);

2
src/c/threads.d
View file

@ -134,7 +134,7 @@ thread_entry_point(cl_object process)
ecl_init_env(env);
init_big_registers(env);
ecl_set_process_env(env);
ecl_enable_interrupts(env);
ecl_enable_interrupts_env(env);
/* 2) Execute the code. The CATCH_ALL point is the destination
* provides us with an elegant way to exit the thread: we just

2
src/cmp/cmpcall.lsp
View file

@ -299,7 +299,7 @@
(format nil "env~D" n)))
(defun wt-stack-pointer (narg)
(wt "cl_env.stack_top-" narg))
(wt "cl_env_copy->stack_top-" narg))
(defun wt-call (fun args &optional fname)
(wt fun "(")

8
src/cmp/cmpcatch.lsp
View file

@ -61,12 +61,12 @@
(*unwind-exit* `((STACK ,sp) ,@*unwind-exit*)))
(wt-nl "{")
(wt-nl "volatile bool unwinding = FALSE;")
(wt-nl "cl_index " sp "=cl_stack_index()," nargs ";")
(wt-nl "cl_index " sp "=ecl_stack_index(cl_env_copy)," nargs ";")
(wt-nl "ecl_frame_ptr next_fr;")
;; Here we compile the form which is protected. When this form
;; is aborted, it continues at the frs_pop() with unwinding=TRUE.
(wt-nl "if (frs_push(ECL_PROTECT_TAG)) {")
(wt-nl " unwinding = TRUE; next_fr=cl_env.nlj_fr;")
(wt-nl " unwinding = TRUE; next_fr=cl_env_copy->nlj_fr;")
(wt-nl "} else {")
(let ((*unwind-exit* (cons 'FRAME *unwind-exit*))
(*destination* 'VALUES))
@ -76,10 +76,10 @@
;; Here we save the values of the form which might have been
;; aborted, and execute some cleanup code. This code may also
;; be aborted by some control structure, but is not protected.
(wt-nl nargs "=cl_stack_push_values();")
(wt-nl nargs "=ecl_stack_push_values(cl_env_copy);")
(let ((*destination* 'TRASH))
(c2expr* body))
(wt-nl "cl_stack_pop_values(" nargs ");")
(wt-nl "ecl_stack_pop_values(cl_env_copy," nargs ");")
;; Finally, if the protected form was aborted, jump to the
;; next catch point...
(wt-nl "if (unwinding) ecl_unwind(next_fr);")

2
src/cmp/cmpcbk.lsp
View file

@ -99,7 +99,7 @@
(when return-p
(wt-nl return-type-name " output;"))
(wt-nl "cl_object aux;")
(wt-nl "ECL_BUILD_STACK_FRAME(frame, helper)")
(wt-nl "ECL_BUILD_STACK_FRAME(cl_env_copy, frame, helper)")
(loop for n from 0
and type in arg-types
and ct in arg-type-constants

4
src/cmp/cmpexit.lsp
View file

@ -19,7 +19,7 @@
(when stack-frame
(if (stringp stack-frame)
(wt-nl "ecl_stack_frame_close(" stack-frame ");")
(wt-nl "cl_stack_set_index(" stack-frame ");")))
(wt-nl "ecl_stack_set_index(cl_env_copy," stack-frame ");")))
(when bds-lcl
(wt-nl "bds_unwind(" bds-lcl ");"))
(if (< bds-bind 4)
@ -81,7 +81,7 @@
(cond ((eq loc 'VALUES)
;; from multiple-value-prog1 or values
(unwind-bds bds-lcl bds-bind stack-frame ihs-p)
(wt-nl "return VALUES(0);"))
(wt-nl "return cl_env_copy->values[0];"))
((eq loc 'RETURN)
;; from multiple-value-prog1 or values
(unwind-bds bds-lcl bds-bind stack-frame ihs-p)

2
src/cmp/cmpffi.lsp
View file

@ -392,7 +392,7 @@
(loop for v in output-vars
for i from 0
do (let ((*destination* `(VALUE ,i))) (set-loc v)))
(wt "NVALUES=" (length output-vars) ";")
(wt "cl_env_copy->nvalues=" (length output-vars) ";")
'VALUES))))))
(defun c2c-inline (arguments &rest rest)

14
src/cmp/cmploc.lsp
View file

@ -74,19 +74,21 @@
(case *destination*
(VALUES
(cond (is-call
(wt-nl "VALUES(0)=") (wt-coerce-loc :object loc) (wt ";"))
(wt-nl "cl_env_copy->values[0]=") (wt-coerce-loc :object loc) (wt ";"))
((eq loc 'VALUES) (return-from set-loc))
(t
(wt-nl "VALUES(0)=") (wt-coerce-loc :object loc) (wt "; NVALUES=1;"))))
(wt-nl "cl_env_copy->values[0]=") (wt-coerce-loc :object loc)
(wt "; cl_env_copy->nvalues=1;"))))
(VALUE0
(wt-nl "value0=") (wt-coerce-loc :object loc) (wt ";"))
(RETURN
(cond ((or is-call (eq loc 'VALUES))
(wt-nl "value0=") (wt-coerce-loc :object loc) (wt ";"))
((eq loc 'VALUE0) (wt-nl "NVALUES=1;"))
((eq loc 'VALUE0) (wt-nl "cl_env_copy->nvalues=1;"))
((eq loc 'RETURN) (return-from set-loc))
(t
(wt-nl "value0=") (wt-coerce-loc :object loc) (wt "; NVALUES=1;"))))
(wt-nl "value0=") (wt-coerce-loc :object loc)
(wt "; cl_env_copy->nvalues=1;"))))
(TRASH
(cond (is-call (wt-nl "(void)" loc ";"))
((and (consp loc)
@ -114,7 +116,7 @@
((eq loc 'RETURN)
(wt "value0")) ; added for last inline-arg
((eq loc 'VALUES)
(wt "VALUES(0)"))
(wt "cl_env_copy->values[0]"))
((eq loc 'VA-ARG)
(wt "va_arg(args,cl_object)"))
((eq loc 'CL-VA-ARG)
@ -166,7 +168,7 @@
(defun wt-character (value &optional vv)
(wt (format nil "'\\~O'" value)))
(defun wt-value (i) (wt "VALUES(" i ")"))
(defun wt-value (i) (wt "cl_env_copy->values[" i "]"))
(defun wt-keyvars (i) (wt "keyvars[" i "]"))

10
src/cmp/cmpmulti.lsp
View file

@ -81,10 +81,10 @@
;; of a function.
((endp forms)
(cond ((eq *destination* 'RETURN)
(wt-nl "value0=Cnil; NVALUES=0;")
(wt-nl "value0=Cnil; cl_env_copy->nvalues=0;")
(unwind-exit 'RETURN))
((eq *destination* 'VALUES)
(wt-nl "VALUES(0)=Cnil; NVALUES=0;")
(wt-nl "cl_env_copy->values[0]=Cnil; cl_env_copy->nvalues=0;")
(unwind-exit 'VALUES))
(t
(unwind-exit 'NIL))))
@ -105,12 +105,12 @@
(forms (nreverse (coerce-locs (inline-args forms)))))
;; By inlining arguments we make sure that VL has no call to funct.
;; Reverse args to avoid clobbering VALUES(0)
(wt-nl "NVALUES=" nv ";")
(wt-nl "cl_env_copy->nvalues=" nv ";")
(do ((vl forms (rest vl))
(i (1- (length forms)) (1- i)))
((null vl))
(declare (fixnum i))
(wt-nl "VALUES(" i ")=" (first vl) ";"))
(wt-nl "cl_env_copy->values[" i "]=" (first vl) ";"))
(unwind-exit 'VALUES)
(close-inline-blocks)))))
@ -195,7 +195,7 @@
;; If there are more variables, we have to check whether there
;; are enough values left in the stack.
(when vars
(wt-nl "{int " nr "=NVALUES-" min-values ";")
(wt-nl "{int " nr "=cl_env_copy->nvalues-" min-values ";")
;;
;; Loop for assigning values to variables
;;

6
src/cmp/cmpstack.lsp
View file

@ -39,7 +39,7 @@
(let* ((new-destination (tmp-destination *destination*))
(*temp* *temp*))
(wt-nl "{ struct ecl_stack_frame _ecl_inner_frame_aux;")
(wt-nl *volatile* "cl_object _ecl_inner_frame = ecl_stack_frame_open((cl_object)&_ecl_inner_frame_aux,0);")
(wt-nl *volatile* "cl_object _ecl_inner_frame = ecl_stack_frame_open(cl_env_copy,(cl_object)&_ecl_inner_frame_aux,0);")
(let* ((*destination* new-destination)
(*unwind-exit* `((STACK ,+ecl-stack-frame-variable+) ,@*unwind-exit*)))
(c2expr* body))
@ -72,12 +72,12 @@
(defun c1stack-pop (args)
(c1expr `(c-inline ,args (t) (values &rest t)
"VALUES(0)=ecl_stack_frame_pop_values(#0);"
"cl_env_copy->values[0]=ecl_stack_frame_pop_values(#0);"
:one-liner nil :side-effects t)))
(defun c1apply-from-stack-frame (args)
(c1expr `(c-inline ,args (t t) (values &rest t)
"VALUES(0)=ecl_apply_from_stack_frame(#0,#1);"
"cl_env_copy->values[0]=ecl_apply_from_stack_frame(#0,#1);"
:one-liner nil :side-effects t)))
(put-sysprop 'with-stack 'C1 #'c1with-stack)

2
src/cmp/cmptag.lsp
View file

@ -156,7 +156,7 @@
(when (and (tag-p tag) (plusp (tag-ref tag)))
(setf (tag-label tag) (next-label))
(setf (tag-unwind-exit tag) label)
(wt-nl "if (VALUES(0)==MAKE_FIXNUM(" (tag-index tag) "))")
(wt-nl "if (cl_env_copy->values[0]==MAKE_FIXNUM(" (tag-index tag) "))")
(wt-go (tag-label tag))))
(when (var-ref-ccb tag-loc)
(wt-nl "ecl_internal_error(\"GO found an inexistent tag\");"))

4
src/cmp/cmptop.lsp
View file

@ -128,6 +128,7 @@
" VLEX" *reservation-cmacro*
" CLSR" *reservation-cmacro*
" STCK" *reservation-cmacro*)
(wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
(wt-nl "cl_object value0;")
(wt-nl "cl_object *VVtemp;")
(when shared-data
@ -398,7 +399,7 @@
(wt-nl1 "{")
(when (compiler-check-args)
(wt-nl "check_arg(" (length arg-types) ");"))
(wt-nl "NVALUES=1;")
(wt-nl "cl_env_copy->nvalues=1;")
(wt-nl "return " (case return-type
(FIXNUM "MAKE_FIXNUM")
(CHARACTER "CODE_CHAR")
@ -582,6 +583,7 @@
" VLEX" *reservation-cmacro*
" CLSR" *reservation-cmacro*
" STCK" *reservation-cmacro*)
(wt-nl "const cl_env_ptr cl_env_copy = ecl_process_env();")
(wt-nl *volatile* "cl_object value0;")
(when (>= (fun-debug fun) 2)
(wt-nl "struct ihs_frame ihs;"))

2
src/cmp/cmpvar.lsp
View file

@ -336,7 +336,7 @@
(sym-loc (make-lcl-var))
(val-loc (make-lcl-var)))
(wt-nl "{cl_object " sym-loc "," val-loc ";")
(wt-nl "cl_index " lcl " = cl_env.bds_top - cl_env.bds_org;")
(wt-nl "cl_index " lcl " = cl_env_copy->bds_top - cl_env_copy->bds_org;")
(push lcl *unwind-exit*)
(let ((*destination* sym-loc)) (c2expr* symbols))

22
src/h/external.h
View file

@ -443,11 +443,11 @@ extern ECL_API cl_object si_eval_with_env _ARGS((cl_narg narg, cl_object form, .
/* interpreter.c */
extern ECL_API cl_object si_interpreter_stack _ARGS((cl_narg narg));
extern ECL_API cl_object ecl_stack_frame_open(cl_object f, cl_index size);
extern ECL_API cl_object ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size);
extern ECL_API void ecl_stack_frame_enlarge(cl_object f, cl_index size);
extern ECL_API void ecl_stack_frame_push(cl_object f, cl_object o);
extern ECL_API void ecl_stack_frame_push_values(cl_object f);
extern ECL_API cl_object ecl_stack_frame_from_va_list(cl_object f, cl_va_list args);
extern ECL_API cl_object ecl_stack_frame_from_va_list(cl_env_ptr env, cl_object f, cl_va_list args);
extern ECL_API cl_object ecl_stack_frame_pop_values(cl_object f);
extern ECL_API cl_object ecl_stack_frame_elt(cl_object f, cl_index n);
extern ECL_API void ecl_stack_frame_elt_set(cl_object f, cl_index n, cl_object o);
@ -459,15 +459,15 @@ extern ECL_API cl_object ecl_apply_from_stack_frame(cl_object f, cl_object o);
extern ECL_API void cl_stack_push(cl_object o);
extern ECL_API cl_object cl_stack_pop(void);
extern ECL_API cl_index cl_stack_index(void);
extern ECL_API void cl_stack_set_size(cl_index new_size);
extern ECL_API void cl_stack_set_index(cl_index sp);
extern ECL_API void cl_stack_pop_n(cl_index n);
extern ECL_API void cl_stack_insert(cl_index where, cl_index n);
extern ECL_API cl_index cl_stack_push_list(cl_object list);
extern ECL_API void cl_stack_push_n(cl_index n, cl_object *args);
extern ECL_API cl_index cl_stack_push_values(void);
extern ECL_API void cl_stack_pop_values(cl_index n);
extern ECL_API cl_index ecl_stack_index(cl_env_ptr);
extern ECL_API void ecl_stack_set_size(cl_env_ptr env, cl_index new_size);
extern ECL_API void ecl_stack_set_index(cl_env_ptr env, cl_index sp);
extern ECL_API void ecl_stack_pop_n(cl_env_ptr env, cl_index n);
extern ECL_API void ecl_stack_insert(cl_env_ptr env, cl_index where, cl_index n);
extern ECL_API cl_index ecl_stack_push_list(cl_env_ptr env, cl_object list);
extern ECL_API void ecl_stack_push_n(cl_env_ptr env, cl_index n, cl_object *args);
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_interpret(cl_object frame, cl_object env, cl_object bytecodes, cl_index offset);
/* disassembler.c */

8
src/h/internal.h
View file

@ -75,12 +75,12 @@ typedef struct cl_compiler_env *cl_compiler_env_ptr;
/* interpreter.d */
#define cl_stack_ref(n) cl_env.stack[n]
#define cl_stack_index() (cl_env.stack_top-cl_env.stack)
#define ecl_stack_ref(env,n) (env)->stack[n]
#define ecl_stack_index(env) ((env)->stack_top-(env)->stack)
#define ECL_BUILD_STACK_FRAME(name,frame) \
#define ECL_BUILD_STACK_FRAME(env,name,frame) \
struct ecl_stack_frame frame;\
cl_object name = ecl_stack_frame_open((cl_object)&frame, 0);
cl_object name = ecl_stack_frame_open(env, (cl_object)&frame, 0);
/* ffi.d */

1
src/h/object.h
View file

@ -645,6 +645,7 @@ struct ecl_stack_frame {
cl_object *bottom; /* Bottom part */
cl_object *top; /* Top part */
cl_object *stack; /* Is this relative to the lisp stack? */
cl_object env;
};
/*

10
src/h/stacks.h
View file

@ -202,13 +202,15 @@ extern ECL_API ecl_frame_ptr _frs_push(register cl_object val);
*********************************/
#define CL_NEWENV_BEGIN {\
cl_index __i = cl_stack_push_values(); \
cl_env_ptr the_env = ecl_process_env(); \
cl_index __i = ecl_stack_push_values(the_env); \
#define CL_NEWENV_END \
cl_stack_pop_values(__i); }
ecl_stack_pop_values(the_env,__i); }
#define CL_UNWIND_PROTECT_BEGIN {\
bool __unwinding; ecl_frame_ptr __next_fr; \
cl_env_ptr the_env = ecl_process_env(); \
cl_index __nr; \
if (frs_push(ECL_PROTECT_TAG)) { \
__unwinding=1; __next_fr=cl_env.nlj_fr; \
@ -217,10 +219,10 @@ extern ECL_API ecl_frame_ptr _frs_push(register cl_object val);
#define CL_UNWIND_PROTECT_EXIT \
__unwinding=0; } \
frs_pop(); \
__nr = cl_stack_push_values();
__nr = ecl_stack_push_values(the_env);
#define CL_UNWIND_PROTECT_END \
cl_stack_pop_values(__nr); \
ecl_stack_pop_values(the_env,__nr); \
if (__unwinding) ecl_unwind(__next_fr); }
#define CL_BLOCK_BEGIN(id) { \