mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-14 13:21:54 -08:00
Code Issues Projects Releases Packages Wiki Activity

Replaced some stack frame functions by internal and faster macros.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2009-02-28 13:14:41 +01:00
parent d019afbb72
commit 529e12a1ed
7 changed files with 80 additions and 104 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/c/eval.d
View file

@ -145,7 +145,7 @@ cl_funcall(cl_narg narg, cl_object function, ...)
(cl_object)&frame_aux,
narg -= 2);
for (i = 0; i < narg; i++) {
ecl_stack_frame_elt_set(frame, i, lastarg);
ECL_STACK_FRAME_SET(frame, i, lastarg);
lastarg = cl_va_arg(args);
}
if (type_of(lastarg) == t_frame) {

6
src/c/gfun.d
View file

@ -47,7 +47,7 @@ user_function_dispatch(cl_narg narg, ...)
const cl_object frame = ecl_stack_frame_open(env, (cl_object)&frame_aux, narg);
cl_va_list args; cl_va_start(args, narg, narg, 0);
for (i = 0; i < narg; i++) {
ecl_stack_frame_elt_set(frame, i, cl_va_arg(args));
ECL_STACK_FRAME_SET(frame, i, cl_va_arg(args));
}
fun = fun->instance.slots[fun->instance.length - 1];
output = ecl_apply_from_stack_frame(frame, fun);
@ -383,7 +383,9 @@ _ecl_standard_dispatch(cl_object frame, cl_object gf)
#if !defined(ECL_USE_VARARG_AS_POINTER)
struct ecl_stack_frame frame_aux;
if (frame->frame.stack == (void*)0x1) {
frame = ecl_stack_frame_copy((cl_object)&frame_aux, frame);
const cl_object new_frame = (cl_object)&frame_aux;
ECL_STACK_FRAME_COPY(new_frame, frame);
frame = new_frame;
}
#endif

52
src/c/interpreter.d
View file

@ -118,19 +118,6 @@ ecl_stack_frame_open(cl_env_ptr env, cl_object f, cl_index size)
return f;
}
void
ecl_stack_frame_enlarge(cl_object f, cl_index size)
{
cl_env_ptr env = f->frame.env;
cl_object *top = env->stack_top;
if ((env->stack_limit - top) < size) {
top = ecl_stack_set_size(env, env->stack_size + size);
}
env->stack_top = (top += size);
f->frame.base = top - (f->frame.size += size);
f->frame.stack = env->stack;
}
void
ecl_stack_frame_push(cl_object f, cl_object o)
{
@ -168,35 +155,6 @@ ecl_stack_frame_pop_values(cl_object f)
return o;
}
cl_object
ecl_stack_frame_elt(cl_object f, cl_index ndx)
{
if (ndx >= f->frame.size) {
FEtype_error_index(f, ecl_make_unsigned_integer(ndx));
}
return f->frame.base[ndx];
}
void
ecl_stack_frame_elt_set(cl_object f, cl_index ndx, cl_object o)
{
if (ndx >= f->frame.size) {
FEtype_error_index(f, ecl_make_unsigned_integer(ndx));
}
f->frame.base[ndx] = o;
}
cl_object
ecl_stack_frame_from_va_list(cl_env_ptr env, cl_object frame, cl_va_list args)
{
cl_index i, nargs = args[0].narg;
ecl_stack_frame_open(env, frame, nargs);
for (i = 0; i < nargs; i++) {
frame->frame.base[i] = cl_va_arg(args);
}
return frame;
}
void
ecl_stack_frame_close(cl_object f)
{
@ -205,16 +163,6 @@ ecl_stack_frame_close(cl_object f)
}
}
cl_object
ecl_stack_frame_copy(cl_object dest, cl_object orig)
{
cl_index size = orig->frame.size;
dest = ecl_stack_frame_open(orig->frame.env, dest, size);
memcpy(dest->frame.base, orig->frame.base, size * sizeof(cl_object));
return dest;
}
/* ------------------------------ LEXICAL ENV. ------------------------------ */
#define bind_var(env, var, val) CONS(CONS(var, val), (env))

85
src/c/mapfun.d
View file

@ -17,37 +17,36 @@
#include <ecl/ecl.h>
#include <ecl/internal.h>
#include <string.h>
#define PREPARE_MAP(list, cdrs_frame, cars_frame, nargs) \
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(ecl_process_env(),\
(cl_object)&cdrs_frame_aux, list); \
cars_frame = ecl_stack_frame_copy((cl_object)&cars_frame_aux, cdrs_frame); \
nargs = cars_frame->frame.size; \
if (nargs == 0) { \
FEprogram_error("MAP*: Too few arguments", 0); \
#define PREPARE_MAP(env, list, cdrs_frame, cars_frame, narg) \
struct ecl_stack_frame frames_aux[2]; \
const cl_object cdrs_frame = (cl_object)frames_aux; \
const cl_object cars_frame = (cl_object)(frames_aux+1); \
ECL_STACK_FRAME_FROM_VA_LIST(env,cdrs_frame,list); \
ECL_STACK_FRAME_COPY(cars_frame, cdrs_frame); \
narg = cars_frame->frame.size; \
if (narg == 0) { \
FEprogram_error("MAP*: Too few arguments", 0); \
}
@(defun mapcar (fun &rest lists)
cl_object res, *val = &res;
cl_index i;
@ {
PREPARE_MAP(lists, cdrs_frame, cars_frame, nargs);
PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg);
res = Cnil;
while (TRUE) {
cl_index i;
for (i = 0; i < nargs; i++) {
cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i);
for (i = 0; i < narg; i++) {
cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i);
if (ecl_endp(cdr)) {
ecl_stack_frame_close(cars_frame);
ecl_stack_frame_close(cdrs_frame);
@(return res)
}
ecl_stack_frame_elt_set(cars_frame, i, CAR(cdr));
ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr));
ECL_STACK_FRAME_SET(cars_frame, i, CAR(cdr));
ECL_STACK_FRAME_SET(cdrs_frame, i, CDR(cdr));
}
*val = ecl_list1(ecl_apply_from_stack_frame(cars_frame, fun));
val = &ECL_CONS_CDR(*val);
@ -57,19 +56,19 @@
@(defun maplist (fun &rest lists)
cl_object res, *val = &res;
@ {
PREPARE_MAP(lists, cdrs_frame, cars_frame, nargs);
PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg);
res = Cnil;
while (TRUE) {
cl_index i;
for (i = 0; i < nargs; i++) {
cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i);
for (i = 0; i < narg; i++) {
cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i);
if (ecl_endp(cdr)) {
ecl_stack_frame_close(cars_frame);
ecl_stack_frame_close(cdrs_frame);
@(return res)
}
ecl_stack_frame_elt_set(cars_frame, i, cdr);
ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr));
ECL_STACK_FRAME_SET(cars_frame, i, cdr);
ECL_STACK_FRAME_SET(cdrs_frame, i, CDR(cdr));
}
*val = ecl_list1(ecl_apply_from_stack_frame(cars_frame, fun));
val = &ECL_CONS_CDR(*val);
@ -79,19 +78,19 @@
@(defun mapc (fun &rest lists)
cl_object onelist;
@ {
PREPARE_MAP(lists, cdrs_frame, cars_frame, nargs);
onelist = ecl_stack_frame_elt(cdrs_frame, 0);
PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg);
onelist = ECL_STACK_FRAME_REF(cdrs_frame, 0);
while (TRUE) {
cl_index i;
for (i = 0; i < nargs; i++) {
cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i);
for (i = 0; i < narg; i++) {
cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i);
if (ecl_endp(cdr)) {
ecl_stack_frame_close(cars_frame);
ecl_stack_frame_close(cdrs_frame);
@(return onelist)
}
ecl_stack_frame_elt_set(cars_frame, i, CAR(cdr));
ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr));
ECL_STACK_FRAME_SET(cars_frame, i, CAR(cdr));
ECL_STACK_FRAME_SET(cdrs_frame, i, CDR(cdr));
}
ecl_apply_from_stack_frame(cars_frame, fun);
}
@ -100,19 +99,19 @@
@(defun mapl (fun &rest lists)
cl_object onelist;
@ {
PREPARE_MAP(lists, cdrs_frame, cars_frame, nargs);
onelist = ecl_stack_frame_elt(cdrs_frame, 0);
PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg);
onelist = ECL_STACK_FRAME_REF(cdrs_frame, 0);
while (TRUE) {
cl_index i;
for (i = 0; i < nargs; i++) {
cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i);
for (i = 0; i < narg; i++) {
cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i);
if (ecl_endp(cdr)) {
ecl_stack_frame_close(cars_frame);
ecl_stack_frame_close(cdrs_frame);
@(return onelist)
}
ecl_stack_frame_elt_set(cars_frame, i, cdr);
ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr));
ECL_STACK_FRAME_SET(cars_frame, i, cdr);
ECL_STACK_FRAME_SET(cdrs_frame, i, CDR(cdr));
}
ecl_apply_from_stack_frame(cars_frame, fun);
}
@ -121,19 +120,19 @@
@(defun mapcan (fun &rest lists)
cl_object res, *val = &res;
@ {
PREPARE_MAP(lists, cdrs_frame, cars_frame, nargs);
PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg);
res = Cnil;
while (TRUE) {
cl_index i;
for (i = 0; i < nargs; i++) {
cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i);
for (i = 0; i < narg; i++) {
cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i);
if (ecl_endp(cdr)) {
ecl_stack_frame_close(cars_frame);
ecl_stack_frame_close(cdrs_frame);
@(return res)
}
ecl_stack_frame_elt_set(cars_frame, i, CAR(cdr));
ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr));
ECL_STACK_FRAME_SET(cars_frame, i, CAR(cdr));
ECL_STACK_FRAME_SET(cdrs_frame, i, CDR(cdr));
}
*val = ecl_apply_from_stack_frame(cars_frame, fun);
while (CONSP(*val))
@ -144,19 +143,19 @@
@(defun mapcon (fun &rest lists)
cl_object res, *val = &res;
@ {
PREPARE_MAP(lists, cdrs_frame, cars_frame, nargs);
PREPARE_MAP(the_env, lists, cdrs_frame, cars_frame, narg);
res = Cnil;
while (TRUE) {
cl_index i;
for (i = 0; i < nargs; i++) {
cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i);
for (i = 0; i < narg; i++) {
cl_object cdr = ECL_STACK_FRAME_REF(cdrs_frame, i);
if (ecl_endp(cdr)) {
ecl_stack_frame_close(cars_frame);
ecl_stack_frame_close(cdrs_frame);
@(return res)
}
ecl_stack_frame_elt_set(cars_frame, i, cdr);
ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr));
ECL_STACK_FRAME_SET(cars_frame, i, cdr);
ECL_STACK_FRAME_SET(cdrs_frame, i, CDR(cdr));
}
*val = ecl_apply_from_stack_frame(cars_frame, fun);
while (CONSP(*val))

7
src/h/external.h
View file

@ -462,14 +462,9 @@ extern ECL_API cl_object si_eval_with_env _ARGS((cl_narg narg, cl_object form, .
extern ECL_API cl_object si_interpreter_stack _ARGS((cl_narg narg));
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_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);
extern ECL_API cl_object ecl_stack_frame_copy(cl_object f, cl_object size);
extern ECL_API void ecl_stack_frame_close(cl_object f);
#define si_apply_from_stack_frame ecl_apply_from_stack_frame
@ -494,7 +489,7 @@ extern ECL_API cl_object si_bc_file(cl_object v);
extern ECL_API cl_object cl_error _ARGS((cl_narg narg, cl_object eformat, ...)) /*__attribute__((noreturn))*/;
extern ECL_API cl_object cl_cerror _ARGS((cl_narg narg, cl_object cformat, cl_object eformat, ...));
extern ECL_API void ecl_inter,nal_error(const char *s) /*__attribute__((noreturn))*/;
extern ECL_API void ecl_internal_error(const char *s) /*__attribute__((noreturn))*/;
extern ECL_API void ecl_cs_overflow(void) /*__attribute__((noreturn))*/;
extern ECL_API void FEprogram_error(const char *s, int narg, ...) /*__attribute__((noreturn))*/;
extern ECL_API void FEcontrol_error(const char *s, int narg, ...) /*__attribute__((noreturn))*/;

21
src/h/internal.h
View file

@ -95,6 +95,27 @@ typedef struct cl_compiler_env *cl_compiler_env_ptr;
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; \
ecl_stack_frame_open((e), __frame, nargs); \
for (i = 0; i < __nargs; i++) { \
__frame->frame.base[i] = cl_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; \

11
src/h/stacks.h
View file

@ -253,6 +253,17 @@ extern ECL_API ecl_frame_ptr _ecl_frs_push(register cl_env_ptr, register cl_obje
} \
__env->stack_top = __new_top + __aux; } while (0)
#define ECL_STACK_FRAME_COPY(dest,orig) do { \
cl_object __dest = (dest); \
cl_object __orig = (orig); \
cl_index __size = __orig->frame.size; \
ecl_stack_frame_open(__orig->frame.env, __dest, __size); \
memcpy(__dest->frame.base, __orig->frame.base, __size * sizeof(cl_object)); \
} while (0);
#define ECL_STACK_FRAME_SET(f,ndx,o) do { (f)->frame.base[(ndx)] = (o); } while(0)
#define ECL_STACK_FRAME_REF(f,ndx) ((f)->frame.base[(ndx)])
/*********************************
* HIGH LEVEL CONTROL STRUCTURES *
*********************************/