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

Optimize some common lisp functions

Browse source
This commit is contained in:
jjgarcia 2008-06-19 15:06:43 +00:00
parent d8122d6c61
commit a2b260c24d
4 changed files with 159 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

99
src/c/compiler.d
View file

@ -109,6 +109,13 @@ static int c_until(cl_object args, int flags);
static int compile_body(cl_object args, int flags);
static int compile_form(cl_object args, int push);
static int c_cons(cl_object args, int push);
static int c_endp(cl_object args, int push);
static int c_car(cl_object args, int push);
static int c_cdr(cl_object args, int push);
static int c_list(cl_object args, int push);
static int c_listA(cl_object args, int push);
static cl_object ecl_make_lambda(cl_object name, cl_object lambda);
static void FEillegal_variable_name(cl_object) /*__attribute__((noreturn))*/;
@ -274,6 +281,17 @@ static compiler_record database[] = {
{@'values', c_values, 1},
{@'si::while', c_while, 0},
{@'si::until', c_until, 0},
/* Extras */
{@'cons', c_cons, 0},
{@'car', c_car, 0},
{@'cdr', c_cdr, 0},
{@'first', c_car, 0},
{@'rest', c_cdr, 0},
{@'list', c_list, 0},
{@'list*', c_listA, 0},
{@'endp', c_endp, 0},
{NULL, NULL, 1}
};
@ -2037,6 +2055,87 @@ compile_body(cl_object body, int flags) {
}
}
/* ------------------------ INLINED FUNCTIONS -------------------------------- */
static int
c_cons(cl_object args, int flags)
{
cl_object car, cdr;
if (ecl_length(args) != 2) {
FEprogram_error("CONS: Wrong number of arguments", 0);
}
compile_form(cl_first(args), FLAG_PUSH);
compile_form(cl_second(args), FLAG_REG0);
asm_op(OP_CONS);
return FLAG_REG0;
}
static int
c_endp(cl_object args, int flags)
{
cl_object list = pop(&args);
if (args != Cnil) {
FEprogram_error("ENDP: Too many arguments", 0);
}
compile_form(list, FLAG_REG0);
asm_op(OP_ENDP);
return FLAG_REG0;
}
static int
c_car(cl_object args, int flags)
{
cl_object list = pop(&args);
if (args != Cnil) {
FEprogram_error("CAR: Too many arguments", 0);
}
compile_form(list, FLAG_REG0);
asm_op(OP_CAR);
return FLAG_REG0;
}
static int
c_cdr(cl_object args, int flags)
{
cl_object list = pop(&args);
if (args != Cnil) {
FEprogram_error("CDR: Too many arguments", 0);
}
compile_form(list, FLAG_REG0);
asm_op(OP_CDR);
return FLAG_REG0;
}
static int
c_list_listA(cl_object args, int flags, int op)
{
cl_index n = ecl_length(args);
if (n == 0) {
return compile_form(Cnil, flags);
} else {
while (ECL_CONS_CDR(args) != Cnil) {
compile_form(ECL_CONS_CAR(args), FLAG_PUSH);
args = ECL_CONS_CDR(args);
}
compile_form(ECL_CONS_CAR(args), FLAG_REG0);
asm_op2(op, n);
return FLAG_REG0;
}
}
static int
c_list(cl_object args, int flags)
{
return c_list_listA(args, flags, OP_LIST);
}
static int
c_listA(cl_object args, int flags)
{
return c_list_listA(args, flags, OP_LISTA);
}
/* ----------------------------- PUBLIC INTERFACE ---------------------------- */
/* ------------------------------------------------------------

12
src/c/disassembler.d
View file

@ -630,6 +630,18 @@ disassemble(cl_object bytecodes, cl_opcode *vector) {
goto ARG;
case OP_STEPOUT: string = "STEP\tOUT";
goto NOARG;
case OP_CONS: string = "CONS"; goto NOARG;
case OP_ENDP: string = "ENDP\tREG0"; goto NOARG;
case OP_CAR: string = "CAR\tREG0"; goto NOARG;
case OP_CDR: string = "CDR\tREG0"; goto NOARG;
case OP_LIST: string = "LIST\t";
n = GET_OPARG(bytecodes);
goto OPARG;
case OP_LISTA: string = "LIST*\t";
n = GET_OPARG(bytecodes);
goto OPARG;
default:
FEerror("Unknown code ~S", 1, MAKE_FIXNUM(*(vector-1)));
return vector;

36
src/c/interpreter.d
View file

@ -597,6 +597,37 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc)
THREAD_NEXT;
}
/* OP_CONS, OP_CAR, OP_CDR, etc act on reg0 and stack. */
CASE(OP_CONS); {
cl_object car = STACK_POP(the_env);
reg0 = CONS(car, reg0);
THREAD_NEXT;
}
CASE(OP_CAR); {
if (!LISTP(reg0)) FEtype_error_cons(reg0);
reg0 = CAR(reg0);
THREAD_NEXT;
}
CASE(OP_CDR); {
if (!LISTP(reg0)) FEtype_error_cons(reg0);
reg0 = CDR(reg0);
THREAD_NEXT;
}
CASE(OP_LIST);
reg0 = ecl_list1(reg0);
CASE(OP_LISTA); {
cl_index n = GET_OPARG(vector);
while (--n) {
reg0 = CONS(STACK_POP(the_env), reg0);
}
THREAD_NEXT;
}
/* OP_PUSH
Pushes the object in VALUES(0).
*/
@ -881,10 +912,15 @@ ecl_interpret(cl_object env, cl_object bytecodes, void *pc)
vector += jump - OPARG_SIZE;
THREAD_NEXT;
}
CASE(OP_ENDP);
if (!LISTP(reg0)) FEtype_error_list(reg0);
CASE(OP_NOT); {
reg0 = (reg0 == Cnil)? Ct : Cnil;
THREAD_NEXT;
}
/* OP_UNBIND n{arg}
Undo "n" local bindings.
*/

12
src/h/bytecodes.h
View file

@ -126,6 +126,12 @@
enum {
OP_NOP,
OP_QUOTE,
OP_ENDP,
OP_CONS,
OP_CAR,
OP_CDR,
OP_LIST,
OP_LISTA,
OP_VAR,
OP_VARS,
OP_PUSH,
@ -248,6 +254,12 @@ typedef int16_t cl_oparg;
static const int offsets[] = {\
&&LBL_OP_NOP - &&LBL_OP_NOP,\
&&LBL_OP_QUOTE - &&LBL_OP_NOP,\
&&LBL_OP_ENDP - &&LBL_OP_NOP,\
&&LBL_OP_CONS - &&LBL_OP_NOP,\
&&LBL_OP_CAR - &&LBL_OP_NOP,\
&&LBL_OP_CDR - &&LBL_OP_NOP,\
&&LBL_OP_LIST - &&LBL_OP_NOP,\
&&LBL_OP_LISTA - &&LBL_OP_NOP,\
&&LBL_OP_VAR - &&LBL_OP_NOP,\
&&LBL_OP_VARS - &&LBL_OP_NOP,\
&&LBL_OP_PUSH - &&LBL_OP_NOP,\