From a2b260c24daa05b7a5ffae4166589f82b26de4d4 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 19 Jun 2008 15:06:43 +0000 Subject: [PATCH] Optimize some common lisp functions --- src/c/compiler.d | 99 ++++++++++++++++++++++++++++++++++++++++++++ src/c/disassembler.d | 12 ++++++ src/c/interpreter.d | 36 ++++++++++++++++ src/h/bytecodes.h | 12 ++++++ 4 files changed, 159 insertions(+) diff --git a/src/c/compiler.d b/src/c/compiler.d index c9d590a2e..fde127f2f 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -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 ---------------------------- */ /* ------------------------------------------------------------ diff --git a/src/c/disassembler.d b/src/c/disassembler.d index 8b19888d9..57cc6ee48 100644 --- a/src/c/disassembler.d +++ b/src/c/disassembler.d @@ -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; diff --git a/src/c/interpreter.d b/src/c/interpreter.d index fc8519ed1..135944d34 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -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. */ diff --git a/src/h/bytecodes.h b/src/h/bytecodes.h index 02d498cb5..cee6db284 100644 --- a/src/h/bytecodes.h +++ b/src/h/bytecodes.h @@ -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,\