diff options
Diffstat (limited to 'lisp/bytecode.c')
| -rw-r--r-- | lisp/bytecode.c | 3707 |
1 files changed, 3707 insertions, 0 deletions
diff --git a/lisp/bytecode.c b/lisp/bytecode.c new file mode 100644 index 0000000..39667b0 --- /dev/null +++ b/lisp/bytecode.c @@ -0,0 +1,3707 @@ +/* + * Copyright (c) 2002 by The XFree86 Project, Inc. + * + * Permission is hereby granted, free of charge, to any person obtaining a + * copy of this software and associated documentation files (the "Software"), + * to deal in the Software without restriction, including without limitation + * the rights to use, copy, modify, merge, publish, distribute, sublicense, + * and/or sell copies of the Software, and to permit persons to whom the + * Software is furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL + * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, + * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF + * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + * + * Except as contained in this notice, the name of the XFree86 Project shall + * not be used in advertising or otherwise to promote the sale, use or other + * dealings in this Software without prior written authorization from the + * XFree86 Project. + * + * Author: Paulo César Pereira de Andrade + */ + +/* $XFree86: xc/programs/xedit/lisp/bytecode.c,v 1.15 2003/01/29 03:05:53 paulo Exp $ */ + + +/* +somethings TODO: + + o Write code for allowing storing the bytecode on disk. Basically + write a section of the bytecode with the package name of the symbol + pointers, and after that, the symbols used. At load time just put + the pointers in the bytecode. Constants can be stored as the string + representation. Probably just storing the gc protected code as a + string is enough to rebuild it. + + o Write code to store tags of BLOCK/CATCH and setjump buffer stacks, + and, only keep track of this if non byte-compiled code is called, + as after byte-compilation RETURN and THROW are just jumps. + + o Remove not reliable "optmization code" code from Com_XXX functions + and do it later, removing dead code, tests with a constant argument, + etc, in the "link time". Frequently joining sequential opcodes to a + compound version. + + o Write an optimizer to do code transformation. + + o Write code to know when variables can be changed in place, this + can save a huge time in loop counters. + + o Write code for fast garbage collection of objects that can be + safely collected. + + o Cleanup of interpreted code. Having bytecode mean that the interpreter + now is better having a clean and small code. If speed is important, + it should be byte compiled. + + o Limit the stacks length. So that instead of using an index, use the + pointer where an object value should be read/stored as the stack address + would not change during the program execution. + + o Optimize jump to jump. Common in code like: + (IF test + (GO somewhere) + (GO elsewhere) + ) + (GO there) + that generates a bytecode like: + <code to evaluate test> + JUMPNIL :NIL-RESULT + :T-RESULT + JUMP :SOMEWHERE + JUMP :END-OF-IF ;; <- this is not required, or even + :NIL-RESULT ;; better, notice the jump after + JUMP :ELSEWHERE ;; the if and transform it into + :END-OF-IF ;; a JUMP :THERE (assuming there + JUMP :THERE ;; (was no jump in the T code). + + o Optimize variables that are known to not change it's value, i.e. pseudo + constants. Loading the value of a constant should be faster than loading + the current value of a variable; the constant table could fit in the + processor cache line and needs less calculation to find the object address. + + o Fix some known problems, like when calling return or return-from while + building the argument list to a builtin function, or inline of recursive + functions. + */ + + +#include "bytecode.h" +#include "write.h" + +#define SYMBOL_KEYWORD -1 /* A keyword, load as constant */ +#define SYMBOL_CONSTANT -2 /* Defined as constant at compile time */ +#define SYMBOL_UNBOUND -3 /* Not a local variable */ + +#define NEW_TREE(type) CompileNewTree(com, type) + +/* If in tagbody, ignore anything that is not code */ +#define IN_TAGBODY() (com->block->type == LispBlockBody && \ + com->level == com->tagbody) +#define FORM_ENTER() ++com->level +#define FORM_LEAVE() --com->level + +#define COMPILE_FAILURE(message) \ + LispMessage("COMPILE: %s", message); \ + longjmp(com->jmp, 1) + +/* + * Types + */ +typedef struct _CodeTree CodeTree; +typedef struct _CodeBlock CodeBlock; + +typedef enum { + CodeTreeBytecode, + CodeTreeLabel, + CodeTreeGo, + CodeTreeJump, + CodeTreeJumpIf, + CodeTreeCond, + CodeTreeBlock, + CodeTreeReturn +} CodeTreeType; + +struct _CodeTree { + CodeTreeType type; + + /* Resolved when linking, may be adjusted while optimizing */ + long offset; + + LispByteOpcode code; + + union { + signed char signed_char; + signed short signed_short; + signed int signed_int; + LispAtom *atom; + LispObj *object; + CodeTree *tree; + CodeBlock *block; + struct { + unsigned char num_arguments; + LispBuiltin *builtin; + signed short offset; /* Used if opcode is XBC_CALL_SET */ + } builtin; + struct { + unsigned char num_arguments; + LispObj *name; + LispObj *lambda; + } call; + struct { + unsigned char num_arguments; + LispObj *code; + } bytecall; + struct { + short offset; + LispAtom *name; + } let; + struct { + LispAtom *symbol; + LispAtom *name; + } let_sym; + struct { + LispObj *object; + LispAtom *name; + } let_con; + struct { + signed short load; + signed short set; + } load_set; + struct { + LispObj *object; + signed short offset; + } load_con_set; + struct { + LispObj *car; + LispObj *cdr; + } cons; + struct { + short offset; + LispObj *definition; + } struc; + } data; + + CodeTree *next; + CodeTree *group; + CodeBlock *block; +}; + +struct _CodeBlock { + LispBlockType type; + LispObj *tag; + + struct { + LispObj **labels; + CodeTree **codes; /* Filled at link time */ + int length; + int space; + } tagbody; + + struct { + LispAtom **symbols; /* Identifiers of variables in a block */ + int *flags; /* Information about usage of the variable */ + int length; + } variables; + + int bind; /* Used in case of RETURN from LET */ + int level; /* Nesting level block was created */ + + CodeTree *tree, *tail; + CodeBlock *prev; /* Linked list as a stack */ + CodeTree *parent; /* Back reference */ +}; + +struct _LispCom { + unsigned char *bytecode; /* Bytecode generated so far */ + long length; + + CodeBlock *block, *toplevel; + + int tagbody; /* Inside a tagbody block? */ + int level; /* Nesting level */ + int macro; /* Expanding a macro? */ + + int lex; + + int warnings; + + LispObj *form, *plist; + + jmp_buf jmp; /* Used if compilation cannot be finished */ + + struct { + int cstack; /* Current number of objects in forms evaluation */ + int cbstack; + int cpstack; + int stack; /* max number of objects will be loaded in stack */ + int bstack; + int pstack; + } stack; + + struct { + /* Constant table */ + LispObj **constants; + int num_constants; + /* Symbol table */ + LispAtom **symbols; + int num_symbols; + /* Builtin table */ + LispBuiltin **builtins; + int num_builtins; + /* Bytecode table */ + LispObj **bytecodes; + int num_bytecodes; + } table; +}; + +/* + * Prototypes + */ +static LispObj *MakeBytecodeObject(LispCom*, LispObj*, LispObj*); + +static CodeTree *CompileNewTree(LispCom*, CodeTreeType); +static void CompileFreeState(LispCom*); +static void CompileFreeBlock(CodeBlock*); +static void CompileFreeTree(CodeTree*); + +static void CompileIniBlock(LispCom*, LispBlockType, LispObj*); +static void CompileFiniBlock(LispCom*); + +static void com_BytecodeChar(LispCom*, LispByteOpcode, char); +static void com_BytecodeShort(LispCom*, LispByteOpcode, short); +static void com_BytecodeObject(LispCom*, LispByteOpcode, LispObj*); +static void com_BytecodeCons(LispCom*, LispByteOpcode, LispObj*, LispObj*); + +static void com_BytecodeAtom(LispCom*, LispByteOpcode, LispAtom*); + +static void com_Bytecode(LispCom*, LispByteOpcode); + +static void com_Load(LispCom*, short); +static void com_LoadLet(LispCom*, short, LispAtom*); +static void com_LoadPush(LispCom*, short); + +static void com_Let(LispCom*, LispAtom*); + +static void com_Bind(LispCom*, short); +static void com_Unbind(LispCom*, short); + +static void com_LoadSym(LispCom*, LispAtom*); +static void com_LoadSymLet(LispCom*, LispAtom*, LispAtom*); +static void com_LoadSymPush(LispCom*, LispAtom*); + +static void com_LoadCon(LispCom*, LispObj*); +static void com_LoadConLet(LispCom*, LispObj*, LispAtom*); +static void com_LoadConPush(LispCom*, LispObj*); + +static void com_Set(LispCom*, short); +static void com_SetSym(LispCom*, LispAtom*); + +static void com_Struct(LispCom*, short, LispObj*); +static void com_Structp(LispCom*, LispObj*); + +static void com_Call(LispCom*, unsigned char, LispBuiltin*); +static void com_Bytecall(LispCom*, unsigned char, LispObj*); +static void com_Funcall(LispCom*, LispObj*, LispObj*); + +static void CompileStackEnter(LispCom*, int, int); +static void CompileStackLeave(LispCom*, int, int); + +static void LinkBytecode(LispCom*); + +static LispObj *ExecuteBytecode(unsigned char*); + + +/* Defined in lisp.c */ +void LispMoreStack(void); +void LispMoreEnvironment(void); +void LispMoreGlobals(LispPackage*); +LispObj *LispEvalBackquote(LispObj*, int); +void LispSetAtomObjectProperty(LispAtom*, LispObj*); + +/* + * Initialization + */ +extern int pagesize; + +LispObj x_cons[8]; +static LispObj *cons, *cons1, *cons2, *cons3, *cons4, *cons5, *cons6, *cons7; + +/* + * Implementation + */ +#include "compile.c" + +void +LispBytecodeInit(void) +{ + cons = &x_cons[7]; + cons->type = LispCons_t; + CDR(cons) = NIL; + cons1 = &x_cons[6]; + cons1->type = LispCons_t; + CDR(cons1) = cons; + cons2 = &x_cons[5]; + cons2->type = LispCons_t; + CDR(cons2) = cons1; + cons3 = &x_cons[4]; + cons3->type = LispCons_t; + CDR(cons3) = cons2; + cons4 = &x_cons[3]; + cons4->type = LispCons_t; + CDR(cons4) = cons3; + cons5 = &x_cons[2]; + cons5->type = LispCons_t; + CDR(cons5) = cons4; + cons6 = &x_cons[1]; + cons6->type = LispCons_t; + CDR(cons6) = cons5; + cons7 = &x_cons[0]; + cons7->type = LispCons_t; + CDR(cons7) = cons6; +} + +LispObj * +Lisp_Compile(LispBuiltin *builtin) +/* + compile name &optional definition + */ +{ + GC_ENTER(); + LispObj *result, *warnings_p, *failure_p; + + LispObj *name, *definition; + + definition = ARGUMENT(1); + name = ARGUMENT(0); + + result = name; + warnings_p = NIL; + failure_p = T; + + if (name != NIL) { + LispAtom *atom; + + CHECK_SYMBOL(name); + atom = name->data.atom; + if (atom->a_builtin || atom->a_compiled) + goto finished_compilation; + else if (atom->a_function) { + LispCom com; + int failed, *pfailed; + int lex, base, *plex, *pbase; + LispArgList *alist; + LispObj *lambda, *form, *arguments, **parguments; + LispObj **presult, **pwarnings_p, **pfailure_p, **pform; + + lambda = atom->property->fun.function; + if (definition != UNSPEC || lambda->funtype != LispFunction) + /* XXX TODO replace definition etc. */ + goto finished_compilation; + alist = atom->property->alist; + + memset(&com, 0, sizeof(LispCom)); + com.toplevel = com.block = LispCalloc(1, sizeof(CodeBlock)); + com.block->type = LispBlockClosure; + com.block->tag = name; + + /* Create a fake argument list to avoid yet another flag + * for ComCall. The value does not matter, just the fact + * that the symbol will be bound or not in the implicit + * PROGN of the function body. */ + base = alist->num_arguments - alist->auxs.num_symbols; + if (base) { + LispObj *argument; + int i, sforms; + + for (i = sforms = 0; i < alist->optionals.num_symbols; i++) + if (alist->optionals.sforms[i]) + ++sforms; + + arguments = form = NIL; + i = sforms + + alist->normals.num_symbols + alist->optionals.num_symbols; + + if (i) { + arguments = form = CONS(NIL, NIL); + GC_PROTECT(arguments); + for (--i; i > 0; i--) { + RPLACD(form, CONS(NIL, NIL)); + form = CDR(form); + } + } + + for (i = 0; i < alist->keys.num_symbols; i++) { + /* key symbol */ + if (alist->keys.keys[i]) + argument = QUOTE(alist->keys.keys[i]); + else + argument = alist->keys.symbols[i]; + + /* add key */ + if (arguments == NIL) { + arguments = form = CONS(argument, NIL); + GC_PROTECT(arguments); + } + else { + RPLACD(form, CONS(argument, NIL)); + form = CDR(form); + } + + /* add value */ + RPLACD(form, CONS(NIL, NIL)); + form = CDR(form); + + if (alist->keys.sforms[i]) { + RPLACD(form, CONS(NIL, NIL)); + form = CDR(form); + } + } + + if (alist->rest) { + if (arguments == NIL) { + arguments = form = CONS(NIL, NIL); + GC_PROTECT(arguments); + } + else { + RPLACD(form, CONS(NIL, NIL)); + form = CDR(form); + } + } + } + else + arguments = NIL; + + form = CONS(lambda->data.lambda.code, NIL); + GC_PROTECT(form); + com.form = form; + com.plist = CONS(NIL, NIL); + GC_PROTECT(com.plist); + + pfailed = &failed; + plex = &lex; + pbase = &base; + pform = &form; + presult = &result; + pwarnings_p = &warnings_p; + pfailure_p = &failure_p; + parguments = &arguments; + failed = 1; + if (setjmp(com.jmp) == 0) { + /* Save interpreter state */ + lex = com.lex = lisp__data.env.lex; + base = ComCall(&com, alist, name, arguments, 1, 0, 1); + + /* Generate code tree */ + lisp__data.env.lex = base; + ComProgn(&com, CAR(form)); + failed = 0; + } + + /* Restore interpreter state */ + lisp__data.env.lex = lex; + lisp__data.env.head = lisp__data.env.length = base; + + if (!failed) { + failure_p = NIL; + result = MakeBytecodeObject(&com, name, + lambda->data.lambda.data); + LispSetAtomCompiledProperty(atom, result); + result = name; + } + if (com.warnings) + warnings_p = FIXNUM(com.warnings); + goto finished_compilation; + } + else + goto undefined_function; + } + +undefined_function: + LispDestroy("%s: the function %s is undefined", + STRFUN(builtin), STROBJ(name)); + +finished_compilation: + RETURN(0) = warnings_p; + RETURN(1) = failure_p; + RETURN_COUNT = 2; + GC_LEAVE(); + + return (result); +} + +LispObj * +Lisp_Disassemble(LispBuiltin *builtin) +/* + disassemble function + */ +{ + int macro; + char buffer[128]; + LispAtom *atom; + LispArgList *alist; + LispBuiltin *xbuiltin; + LispObj *name, *lambda, *bytecode; + + LispObj *function; + + function = ARGUMENT(0); + + macro = 0; + alist = NULL; + xbuiltin = NULL; + name = bytecode = NULL; + + switch (OBJECT_TYPE(function)) { + case LispAtom_t: + name = function; + atom = function->data.atom; + alist = atom->property->alist; + if (atom->a_builtin) { + xbuiltin = atom->property->fun.builtin; + macro = xbuiltin->type == LispMacro; + } + else if (atom->a_compiled) + bytecode = atom->property->fun.function; + else if (atom->a_function) { + lambda = atom->property->fun.function; + macro = lambda->funtype == LispMacro; + } + else if (atom->a_defstruct && + atom->property->structure.function != STRUCT_NAME) { + if (atom->property->structure.function == STRUCT_CONSTRUCTOR) + atom = Omake_struct->data.atom; + else if (atom->property->structure.function == STRUCT_CHECK) + atom = Ostruct_type->data.atom; + else + atom = Ostruct_access->data.atom; + xbuiltin = atom->property->fun.builtin; + } + else + LispDestroy("%s: the function %s is not defined", + STRFUN(builtin), STROBJ(function)); + break; + case LispBytecode_t: + name = Olambda; + bytecode = function; + break; + case LispLambda_t: + name = Olambda; + alist = (LispArgList*)function->data.lambda.name->data.opaque.data; + break; + case LispCons_t: + if (CAR(function) == Olambda) { + function = EVAL(function); + if (OBJECT_TYPE(function) == LispLambda_t) { + name = Olambda; + alist = (LispArgList*) + function->data.lambda.name->data.opaque.data; + break; + } + } + default: + LispDestroy("%s: %s is not a function", + STRFUN(builtin), STROBJ(function)); + break; + } + + if (xbuiltin) { + LispWriteStr(NIL, "Builtin ", 8); + if (macro) + LispWriteStr(NIL, "macro ", 6); + else + LispWriteStr(NIL, "function ", 9); + } + else if (macro) + LispWriteStr(NIL, "Macro ", 6); + else + LispWriteStr(NIL, "Function ", 9); + LispWriteObject(NIL, name); + LispWriteStr(NIL, ":\n", 2); + + if (alist) { + int i; + + sprintf(buffer, "%d required argument%s", + alist->normals.num_symbols, + alist->normals.num_symbols != 1 ? "s" : ""); + LispWriteStr(NIL, buffer, strlen(buffer)); + for (i = 0; i < alist->normals.num_symbols; i++) { + LispWriteChar(NIL, i ? ',' : ':'); + LispWriteChar(NIL, ' '); + LispWriteStr(NIL, ATOMID(alist->normals.symbols[i]), + strlen(ATOMID(alist->normals.symbols[i]))); + } + LispWriteChar(NIL, '\n'); + + sprintf(buffer, "%d optional argument%s", + alist->optionals.num_symbols, + alist->optionals.num_symbols != 1 ? "s" : ""); + LispWriteStr(NIL, buffer, strlen(buffer)); + for (i = 0; i < alist->optionals.num_symbols; i++) { + LispWriteChar(NIL, i ? ',' : ':'); + LispWriteChar(NIL, ' '); + LispWriteStr(NIL, ATOMID(alist->optionals.symbols[i]), + strlen(ATOMID(alist->optionals.symbols[i]))); + } + LispWriteChar(NIL, '\n'); + + sprintf(buffer, "%d keyword parameter%s", + alist->keys.num_symbols, + alist->keys.num_symbols != 1 ? "s" : ""); + LispWriteStr(NIL, buffer, strlen(buffer)); + for (i = 0; i < alist->keys.num_symbols; i++) { + LispWriteChar(NIL, i ? ',' : ':'); + LispWriteChar(NIL, ' '); + LispWriteObject(NIL, alist->keys.symbols[i]); + } + LispWriteChar(NIL, '\n'); + + if (alist->rest) { + LispWriteStr(NIL, "Rest argument: ", 15); + LispWriteStr(NIL, ATOMID(alist->rest), + strlen(ATOMID(alist->rest))); + LispWriteChar(NIL, '\n'); + } + else + LispWriteStr(NIL, "No rest argument\n", 17); + } + + if (bytecode) { + char *ptr; + int *offsets[4]; + int i, done, j, sym0, sym1, con0, con1, bui0, byt0, strd, strf; + LispObj **constants; + LispAtom **symbols; + LispBuiltin **builtins; + unsigned char **codes; + LispObj **names; + short stack, num_constants, num_symbols, num_builtins, num_bytecodes; + unsigned char *base, *stream = bytecode->data.bytecode.bytecode->code; + + LispWriteStr(NIL, "\nBytecode header:\n", 18); + + /* Header information */ + stack = *(short*)stream; + stream += sizeof(short); + sprintf(buffer, "%d element%s used in the stack\n", + stack, stack != 1 ? "s" : ""); + LispWriteStr(NIL, buffer, strlen(buffer)); + stack = *(short*)stream; + stream += sizeof(short); + sprintf(buffer, "%d element%s used in the builtin stack\n", + stack, stack != 1 ? "s" : ""); + LispWriteStr(NIL, buffer, strlen(buffer)); + stack = *(short*)stream; + stream += sizeof(short); + sprintf(buffer, "%d element%s used in the protected stack\n", + stack, stack != 1 ? "s" : ""); + LispWriteStr(NIL, buffer, strlen(buffer)); + + num_constants = *(short*)stream; + stream += sizeof(short); + num_symbols = *(short*)stream; + stream += sizeof(short); + num_builtins = *(short*)stream; + stream += sizeof(short); + num_bytecodes = *(short*)stream; + stream += sizeof(short); + + constants = (LispObj**)stream; + stream += num_constants * sizeof(LispObj*); + symbols = (LispAtom**)stream; + stream += num_symbols * sizeof(LispAtom*); + builtins = (LispBuiltin**)stream; + stream += num_builtins * sizeof(LispBuiltin*); + codes = (unsigned char**)stream; + stream += num_bytecodes * sizeof(unsigned char*); + names = (LispObj**)stream; + stream += num_bytecodes * sizeof(LispObj*); + + for (i = 0; i < num_constants; i++) { + sprintf(buffer, "Constant %d = %s\n", i, STROBJ(constants[i])); + LispWriteStr(NIL, buffer, strlen(buffer)); + } + +/* Macro XSTRING avoids some noisy in the output, if it were defined as + * #define XSTRING(object) object ? STROBJ(object) : #<UNBOUND> + * and called as XSTRING(atom->object) + * it would also print the package name were the symbol was first defined, + * but for local variables, only the symbol string is important. */ +#define XSTRING(string) string ? string : "#<UNBOUND>" + + for (i = 0; i < num_symbols; i++) { + sprintf(buffer, "Symbol %d = %s\n", + i, XSTRING(symbols[i]->string)); + LispWriteStr(NIL, buffer, strlen(buffer)); + } + for (i = 0; i < num_builtins; i++) { + sprintf(buffer, "Builtin %d = %s\n", + i, STROBJ(builtins[i]->symbol)); + LispWriteStr(NIL, buffer, strlen(buffer)); + } + for (i = 0; i < num_bytecodes; i++) { + sprintf(buffer, "Bytecode %d = %s\n", + i, STROBJ(names[i])); + LispWriteStr(NIL, buffer, strlen(buffer)); + } + + /* Make readability slightly easier printing the names of local + * variables where it's offset is known, i.e. function arguments. */ + if (alist) { + if (alist->num_arguments == 0) + LispWriteStr(NIL, "\nNo initial stack\n", 18); + else { + int len1, len2; + + j = 0; + LispWriteStr(NIL, "\nInitial stack:\n", 16); + + for (i = 0; i < alist->normals.num_symbols; i++, j++) { + sprintf(buffer, "%d = ", j); + LispWriteStr(NIL, buffer, strlen(buffer)); + ptr = alist->normals.symbols[i]->data.atom->string; + LispWriteStr(NIL, ptr, strlen(ptr)); + LispWriteChar(NIL, '\n'); + } + + for (i = 0; i < alist->optionals.num_symbols; i++, j++) { + sprintf(buffer, "%d = ", j); + LispWriteStr(NIL, buffer, strlen(buffer)); + ptr = alist->optionals.symbols[i]->data.atom->string; + LispWriteStr(NIL, ptr, strlen(ptr)); + LispWriteChar(NIL, '\n'); + if (alist->optionals.sforms[i]) { + sprintf(buffer, "%d = ", j); + len1 = strlen(buffer); + LispWriteStr(NIL, buffer, len1); + ptr = alist->optionals.sforms[i]->data.atom->string; + len2 = strlen(ptr); + LispWriteStr(NIL, ptr, len2); + LispWriteChars(NIL, ' ', 28 - (len1 + len2)); + LispWriteStr(NIL, "; sform\n", 9); + j++; + } + } + + for (i = 0; i < alist->keys.num_symbols; i++, j++) { + sprintf(buffer, "%d = ", j); + len1 = strlen(buffer); + LispWriteStr(NIL, buffer, len1); + if (alist->keys.keys[i]) { + ptr = alist->keys.keys[i]->data.atom->string; + len2 = strlen(ptr); + LispWriteStr(NIL, ptr, strlen(ptr)); + LispWriteChars(NIL, ' ', 28 - (len1 + len2)); + LispWriteStr(NIL, "; special key", 14); + } + else { + ptr = alist->keys.symbols[i]->data.atom->string; + LispWriteStr(NIL, ptr, strlen(ptr)); + } + LispWriteChar(NIL, '\n'); + if (alist->keys.sforms[i]) { + sprintf(buffer, "%d = ", j); + len1 = strlen(buffer); + LispWriteStr(NIL, buffer, len1); + ptr = alist->keys.sforms[i]->data.atom->string; + len2 = strlen(ptr); + LispWriteStr(NIL, ptr, len2); + LispWriteChars(NIL, ' ', 28 - (len1 + len2)); + LispWriteStr(NIL, "; sform\n", 9); + j++; + } + } + + if (alist->rest) { + sprintf(buffer, "%d = ", j); + len1 = strlen(buffer); + LispWriteStr(NIL, buffer, len1); + ptr = alist->rest->data.atom->string; + len2 = strlen(ptr); + LispWriteStr(NIL, ptr, len2); + LispWriteChar(NIL, '\n'); + j++; + } + + for (i = 0; i < alist->auxs.num_symbols; i++, j++) { + sprintf(buffer, "%d = ", j); + len1 = strlen(buffer); + LispWriteStr(NIL, buffer, len1); + ptr = alist->auxs.symbols[i]->data.atom->string; + len2 = strlen(ptr); + LispWriteStr(NIL, ptr, len2); + LispWriteChars(NIL, ' ', 28 - (len1 + len2)); + LispWriteStr(NIL, "; aux\n", 7); + } + } + } + + LispWriteStr(NIL, "\nBytecode stream:\n", 18); + + base = stream; + for (done = j = 0; !done; j = 0) { + sym0 = sym1 = con0 = con1 = bui0 = byt0 = strd = strf = -1; + sprintf(buffer, "%4ld ", (long)(stream - base)); + ptr = buffer + strlen(buffer); + switch (*stream++) { + case XBC_NOOP: strcpy(ptr, "NOOP"); break; + case XBC_PRED: + strcpy(ptr, "PRED:"); + ptr += strlen(ptr); + goto predicate; + case XBC_INV: strcpy(ptr, "INV"); break; + case XBC_NIL: strcpy(ptr, "NIL"); break; + case XBC_T: strcpy(ptr, "T"); break; + case XBC_CAR: strcpy(ptr, "CAR"); break; + case XBC_CDR: strcpy(ptr, "CDR"); break; + case XBC_RPLACA:strcpy(ptr, "RPLACA"); break; + case XBC_RPLACD:strcpy(ptr, "RPLACD"); break; + case XBC_EQ: strcpy(ptr, "EQ"); break; + case XBC_EQL: strcpy(ptr, "EQL"); break; + case XBC_EQUAL: strcpy(ptr, "EQUAL"); break; + case XBC_EQUALP:strcpy(ptr, "EQUALP"); break; + case XBC_LENGTH:strcpy(ptr, "LENGTH"); break; + case XBC_LAST: strcpy(ptr, "LAST"); break; + case XBC_NTHCDR:strcpy(ptr, "NTHCDR"); break; + case XBC_PUSH: strcpy(ptr, "PUSH"); break; + case XBC_CAR_PUSH: + strcpy(ptr, "CAR&PUSH"); + break; + case XBC_CDR_PUSH: + strcpy(ptr, "CDR&PUSH"); + break; + case XBC_PUSH_NIL: + strcpy(ptr, "PUSH NIL"); + break; + case XBC_PUSH_UNSPEC: + strcpy(ptr, "PUSH #<UNSPEC>"); + break; + case XBC_PUSH_T: + strcpy(ptr, "PUSH T"); + break; + case XBC_PUSH_NIL_N: + strcpy(ptr, "PUSH NIL "); + ptr += strlen(ptr); + sprintf(ptr, "%d", (int)(*stream++)); + break; + case XBC_PUSH_UNSPEC_N: + strcpy(ptr, "PUSH #<UNSPEC> "); + ptr += strlen(ptr); + sprintf(ptr, "%d", (int)(*stream++)); + break; + case XBC_LET: + strcpy(ptr, "LET"); +/* update sym0 */ +symbol: + offsets[j++] = &sym0; +/* update <offsets> - print [byte] */ +offset: + ptr += strlen(ptr); + i = *stream++; + *(offsets[j - 1]) = i; + sprintf(ptr, " [%d]", i); + break; + case XBC_LETX: + strcpy(ptr, "LET*"); + goto symbol; + case XBC_LET_NIL: + strcpy(ptr, "LET NIL"); + goto symbol; + case XBC_LETX_NIL: + strcpy(ptr, "LET* NIL"); + goto symbol; + case XBC_LETBIND: + strcpy(ptr, "LETBIND"); +/* print byte */ +value: + ptr += strlen(ptr); + sprintf(ptr, " %d", (int)(*stream++)); + break; + case XBC_UNLET:strcpy(ptr, "UNLET"); goto value; + case XBC_LOAD: + strcpy(ptr, "LOAD"); +/* print (byte) */ +reference: + ptr += strlen(ptr); + i = *stream++; + sprintf(ptr, " (%d)", i); + break; + case XBC_LOAD_CAR: + strcpy(ptr, "LOAD&CAR"); + goto reference; + case XBC_LOAD_CDR: + strcpy(ptr, "LOAD&CDR"); + goto reference; + case XBC_LOAD_CAR_STORE: + strcpy(ptr, "LOAD&CAR&STORE"); + goto reference; + case XBC_LOAD_CDR_STORE: + strcpy(ptr, "LOAD&CDR&STORE"); + goto reference; + case XBC_LOAD_LET: + strcpy(ptr, "LOAD&LET"); +load_let: + offsets[j++] = &sym0; + i = *stream++; + ptr += strlen(ptr); + sprintf(ptr, " (%d)", i); + goto offset; + case XBC_LOAD_LETX: + strcpy(ptr, "LOAD&LET*"); + goto load_let; + case XBC_STRUCT: + strcpy(ptr, "STRUCT"); + offsets[j++] = &strf; + offsets[j++] = &strd; +/* update <offsets> - print [byte] - update <offsets> - print [byte] */ +offset_offset: + ptr += strlen(ptr); + i = *stream++; + *(offsets[j - 2]) = i; + sprintf(ptr, " [%d]", i); + goto offset; + case XBC_LOAD_PUSH: + strcpy(ptr, "LOAD&PUSH"); + goto reference; + case XBC_LOADCON: + strcpy(ptr, "LOADCON"); +constant: + offsets[j++] = &con0; + goto offset; + case XBC_LOADCON_SET: + strcpy(ptr, "LOADCON&SET"); + offsets[j++] = &con0; +/* update <offsets> - print [byte] - print (byte) */ +offset_reference: + i = *stream++; + *(offsets[j - 1]) = i; + ptr += strlen(ptr); + sprintf(ptr, " [%d]", i); + goto reference; + case XBC_STRUCTP: + strcpy(ptr, "STRUCTP"); + offsets[j++] = &strd; + goto offset; + case XBC_LOADCON_LET: + strcpy(ptr, "LOADCON&LET"); +loadcon_let: + offsets[j++] = &con0; + offsets[j++] = &sym0; + goto offset_offset; + case XBC_LOADCON_LETX: + strcpy(ptr, "LOADCON&LET*"); + goto loadcon_let; + case XBC_LOADCON_PUSH: + strcpy(ptr, "LOADCON&PUSH"); + goto constant; + case XBC_LOADSYM: + strcpy(ptr, "LOADSYM"); + goto symbol; + case XBC_LOADSYM_LET: + strcpy(ptr, "LOADSYM&LET"); +loadsym_let: + offsets[j++] = &sym0; + offsets[j++] = &sym1; + goto offset_offset; + case XBC_LOADSYM_LETX: + strcpy(ptr, "LOADSYM&LET*"); + goto loadsym_let; + case XBC_LOADSYM_PUSH: + strcpy(ptr, "LOADSYM&PUSH"); + goto symbol; + case XBC_LOAD_SET: + strcpy(ptr, "LOAD&SET"); +/* print (byte) - print (byte) */ +reference_reference: + ptr += strlen(ptr); + i = *stream++; + sprintf(ptr, " (%d)", i); + goto reference; + case XBC_LOAD_CAR_SET: + strcpy(ptr, "LOAD&CAR&SET"); + goto reference_reference; + case XBC_LOAD_CDR_SET: + strcpy(ptr, "LOAD&CDR&SET"); + goto reference_reference; + case XBC_CAR_SET: + strcpy(ptr, "CAR&SET"); + goto reference; + case XBC_CDR_SET: + strcpy(ptr, "CDR&SET"); + goto reference; + case XBC_SET: + strcpy(ptr, "SET"); + goto reference; + case XBC_SETSYM: + strcpy(ptr, "SETSYM"); + goto symbol; + case XBC_SET_NIL: + strcpy(ptr, "SET NIL"); + goto reference; + case XBC_CALL: + strcpy(ptr, "CALL"); + ptr += strlen(ptr); + sprintf(ptr, " %d", (int)(*stream++)); + offsets[j++] = &bui0; + goto offset; + case XBC_CALL_SET: + strcpy(ptr, "CALL&SET"); + ptr += strlen(ptr); + sprintf(ptr, " %d", (int)(*stream++)); + offsets[j++] = &bui0; + goto offset_reference; + case XBC_BYTECALL: + strcpy(ptr, "BYTECALL"); + ptr += strlen(ptr); + sprintf(ptr, " %d", (int)(*stream++)); + offsets[j++] = &byt0; + goto offset; + case XBC_FUNCALL: + strcpy(ptr, "FUNCALL"); +constant_constant: + offsets[j++] = &con0; + offsets[j++] = &con1; + goto offset_offset; + case XBC_CCONS: + strcpy(ptr, "CCONS"); + goto constant_constant; + case XBC_CSTAR: strcpy(ptr, "CSTAR"); break; + case XBC_CFINI: strcpy(ptr, "CFINI"); break; + case XBC_LSTAR: strcpy(ptr, "LSTAR"); break; + case XBC_LCONS: strcpy(ptr, "LCONS"); break; + case XBC_LFINI: strcpy(ptr, "LFINI"); break; + case XBC_BCONS: strcpy(ptr, "BCONS"); break; + case XBC_BCONS1: case XBC_BCONS2: case XBC_BCONS3: + case XBC_BCONS4: case XBC_BCONS5: case XBC_BCONS6: + case XBC_BCONS7: + strcpy(ptr, "BCONS"); + ptr += strlen(ptr); + sprintf(ptr, "%d", (int)(stream[-1] - XBC_BCONS)); + break; + case XBC_JUMP: + strcpy(ptr, "JUMP"); +integer: + ptr += strlen(ptr); + sprintf(ptr, " %d", *(signed short*)stream); + stream += sizeof(short); + break; + case XBC_JUMPT: + strcpy(ptr, "JUMPT"); + goto integer; + case XBC_JUMPNIL: + strcpy(ptr, "JUMPNIL"); + goto integer; + case XBC_LETREC: + strcpy(ptr, "LETREC"); + ptr += strlen(ptr); + sprintf(ptr, " %d", (int)*stream++); + break; + case XBC_RETURN: + strcpy(ptr, "RETURN"); + done = 1; + break; + } + i = ptr - buffer + strlen(ptr); + LispWriteStr(NIL, buffer, i); + if (j) { + + /* Pad */ + LispWriteChars(NIL, ' ', 28 - i); + LispWriteChar(NIL, ';'); + + ptr = buffer; + + /* Structure */ + if (strf >= 0) { + /* strd is valid if strf set */ + LispObj *fields = constants[strd]; + + for (; strf >= 0; strf--) + fields = CDR(fields); + strcpy(ptr, " "); ptr += 2; + strcpy(ptr, CAR(fields)->data.atom->string); + ptr += strlen(ptr); + } + if (strd >= 0) { + strcpy(ptr, " "); ptr += 2; + strcpy(ptr, STROBJ(CAR(constants[strd]))); + ptr += strlen(ptr); + } + + /* Constants */ + if (con0 >= 0) { + strcpy(ptr, " "); ptr += 2; + strcpy(ptr, STROBJ(constants[con0])); + ptr += strlen(ptr); + if (con1 >= 0) { + strcpy(ptr, " "); ptr += 2; + strcpy(ptr, STROBJ(constants[con1])); + ptr += strlen(ptr); + } + } + + /* Builtin */ + if (bui0 >= 0) { + strcpy(ptr, " "); ptr += 2; + strcpy(ptr, STROBJ(builtins[bui0]->symbol)); + ptr += strlen(ptr); + } + + /* Bytecode */ + if (byt0 >= 0) { + strcpy(ptr, " "); ptr += 2; + strcpy(ptr, STROBJ(names[byt0])); + ptr += strlen(ptr); + } + + /* Symbols */ + if (sym0 >= 0) { + strcpy(ptr, " "); ptr += 2; + strcpy(ptr, XSTRING(symbols[sym0]->string)); + ptr += strlen(ptr); + if (sym1 >= 0) { + strcpy(ptr, " "); ptr += 2; + strcpy(ptr, XSTRING(symbols[sym1]->string)); + ptr += strlen(ptr); + } + } + + i = ptr - buffer; + LispWriteStr(NIL, buffer, i); + } + LispWriteChar(NIL, '\n'); + continue; +predicate: + switch (*stream++) { + case XBP_CONSP: strcpy(ptr, "CONSP"); break; + case XBP_LISTP: strcpy(ptr, "LISTP"); break; + case XBP_NUMBERP: strcpy(ptr, "NUMBERP"); break; + } + LispWriteStr(NIL, buffer, ptr - buffer + strlen(ptr)); + LispWriteChar(NIL, '\n'); + } +#undef XSTRING + } + + return (function); +} + + + +LispObj * +LispCompileForm(LispObj *form) +{ + GC_ENTER(); + int failed, *pfailed; + LispCom com; + LispObj *code, **pform; + + if (!CONSP(form)) + /* Incorrect call or NIL */ + return (form); + + memset(&com, 0, sizeof(LispCom)); + + com.toplevel = com.block = LispCalloc(1, sizeof(CodeBlock)); + com.block->type = LispBlockNone; + com.lex = lisp__data.env.lex; + + com.plist = CONS(NIL, NIL); + GC_PROTECT(com.plist); + + pfailed = &failed; + pform = &form; + failed = 1; + if (setjmp(com.jmp) == 0) { + for (code = form; CONSP(form); form = CDR(form)) { + com.form = form; + ComEval(&com, CAR(form)); + } + failed = 0; + } + GC_LEAVE(); + + return (failed ? NIL : MakeBytecodeObject(&com, NIL, NIL)); +} + +LispObj * +LispExecuteBytecode(LispObj *object) +{ + if (!BYTECODEP(object)) + return (EVAL(object)); + + return (ExecuteBytecode(object->data.bytecode.bytecode->code)); +} + +static LispObj * +MakeBytecodeObject(LispCom *com, LispObj *name, LispObj *plist) +{ + LispObj *object; + LispBytecode *bytecode; + + GC_ENTER(); + unsigned char *stream; + short i, num_constants; + LispObj **constants, *code, *cons, *prev; + + /* Resolve dependencies, optimize and create byte stream */ + LinkBytecode(com); + + object = LispNew(NIL, NIL); + GC_PROTECT(object); + bytecode = LispMalloc(sizeof(LispBytecode)); + bytecode->code = com->bytecode; + bytecode->length = com->length; + + + stream = bytecode->code; + + /* Skip stack information */ + stream += sizeof(short) * 3; + + /* Get information */ + num_constants = *(short*)stream; + stream += sizeof(short) * 4; + constants = (LispObj**)stream; + + GC_PROTECT(plist); + code = cons = prev = NIL; + for (i = 0; i < num_constants; i++) { + if (POINTERP(constants[i]) && !XSYMBOLP(constants[i])) { + if (code == NIL) { + code = cons = prev = CONS(constants[i], NIL); + GC_PROTECT(code); + } + else { + RPLACD(cons, CONS(constants[i], NIL)); + prev = cons; + cons = CDR(cons); + } + } + } + + /* Protect this in case the function is redefined */ + for (i = 0; i < com->table.num_bytecodes; i++) { + if (code == NIL) { + code = cons = prev = CONS(com->table.bytecodes[i], NIL); + GC_PROTECT(code); + } + else { + RPLACD(cons, CONS(com->table.bytecodes[i], NIL)); + prev = cons; + cons = CDR(cons); + } + } + + /* Free everything, but the LispCom structure and the generated bytecode */ + CompileFreeState(com); + + /* Allocate the minimum required number of cons cells to protect objects */ + if (!CONSP(code)) + code = plist; + else if (CONSP(plist)) { + if (code == cons) + RPLACD(code, plist); + else + RPLACD(cons, plist); + } + else { + if (code == cons) + code = CAR(code); + else + CDR(prev) = CAR(cons); + } + + object->data.bytecode.bytecode = bytecode; + /* Byte code references this object, so it cannot be garbage collected */ + object->data.bytecode.code = code; + object->data.bytecode.name = name; + object->type = LispBytecode_t; + + LispMused(bytecode); + LispMused(bytecode->code); + GC_LEAVE(); + + return (object); +} + +static void +CompileFreeTree(CodeTree *tree) +{ + if (tree->type == CodeTreeBlock) + CompileFreeBlock(tree->data.block); + LispFree(tree); +} + +static void +CompileFreeBlock(CodeBlock *block) +{ + CodeTree *tree = block->tree, *next; + + while (tree) { + next = tree->next; + CompileFreeTree(tree); + tree = next; + } + if (block->type == LispBlockBody) { + LispFree(block->tagbody.labels); + LispFree(block->tagbody.codes); + } + LispFree(block->variables.symbols); + LispFree(block->variables.flags); + LispFree(block); +} + +static void +CompileFreeState(LispCom *com) +{ + CompileFreeBlock(com->block); + LispFree(com->table.constants); + LispFree(com->table.symbols); + LispFree(com->table.builtins); + LispFree(com->table.bytecodes); +} + +/* XXX Put a breakpoint here when changing the macro expansion code. + * No opcodes should be generated during macro expansion. */ +static CodeTree * +CompileNewTree(LispCom *com, CodeTreeType type) +{ + CodeTree *tree = LispMalloc(sizeof(CodeTree)); + + tree->type = type; + tree->next = NULL; + tree->block = com->block; + if (com->block->tree == NULL) + com->block->tree = tree; + else + com->block->tail->next = tree; + com->block->tail = tree; + + return (tree); +} + +static void +CompileIniBlock(LispCom *com, LispBlockType type, LispObj *tag) +{ + CodeTree *tree = NEW_TREE(CodeTreeBlock); + CodeBlock *block = LispCalloc(1, sizeof(CodeBlock)); + + tree->data.block = block; + + block->type = type; + block->tag = tag; + block->prev = com->block; + block->parent = tree; + block->level = com->level; + com->block = block; + + if (type == LispBlockBody) + com->tagbody = com->level; +} + +static void +CompileFiniBlock(LispCom *com) +{ + com->block = com->block->prev; + if (com->block && com->block->type == LispBlockBody) + com->tagbody = com->block->level; +} + +static void +com_BytecodeChar(LispCom *com, LispByteOpcode code, char value) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = code; + tree->data.signed_char = value; +} + +static void +com_BytecodeShort(LispCom *com, LispByteOpcode code, short value) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = code; + tree->data.signed_short = value; +} + +static void +com_BytecodeAtom(LispCom *com, LispByteOpcode code, LispAtom *atom) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = code; + tree->data.atom = atom; +} + +static void +com_BytecodeObject(LispCom *com, LispByteOpcode code, LispObj *object) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = code; + tree->data.object = object; +} + +static void +com_BytecodeCons(LispCom *com, LispByteOpcode code, LispObj *car, LispObj *cdr) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = code; + tree->data.cons.car = car; + tree->data.cons.cdr = cdr; +} + +static void +com_Bytecode(LispCom *com, LispByteOpcode code) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = code; +} + +static void +com_Load(LispCom *com, short offset) +{ + com_BytecodeShort(com, XBC_LOAD, offset); +} + +static void +com_LoadLet(LispCom *com, short offset, LispAtom *name) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = XBC_LOAD_LET; + tree->data.let.offset = offset; + tree->data.let.name = name; +} + +static void +com_LoadPush(LispCom *com, short offset) +{ + com_BytecodeShort(com, XBC_LOAD_PUSH, offset); +} + +static void +com_Let(LispCom *com, LispAtom *name) +{ + com_BytecodeAtom(com, XBC_LET, name); +} + +static void +com_Bind(LispCom *com, short count) +{ + if (count) + com_BytecodeShort(com, XBC_LETBIND, count); +} + +static void +com_Unbind(LispCom *com, short count) +{ + if (count) + com_BytecodeShort(com, XBC_UNLET, count); +} + +static void +com_LoadSym(LispCom *com, LispAtom *atom) +{ + com_BytecodeAtom(com, XBC_LOADSYM, atom); +} + +static void +com_LoadSymLet(LispCom *com, LispAtom *symbol, LispAtom *name) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = XBC_LOADSYM_LET; + tree->data.let_sym.symbol = symbol; + tree->data.let_sym.name = name; +} + +static void +com_LoadSymPush(LispCom *com, LispAtom *name) +{ + com_BytecodeAtom(com, XBC_LOADSYM_PUSH, name); +} + +static void +com_LoadCon(LispCom *com, LispObj *constant) +{ + if (constant == NIL) + com_Bytecode(com, XBC_NIL); + else if (constant == T) + com_Bytecode(com, XBC_T); + else if (constant == UNSPEC) { + COMPILE_FAILURE("internal error: loading #<UNSPEC>"); + } + else + com_BytecodeObject(com, XBC_LOADCON, constant); +} + +static void +com_LoadConLet(LispCom *com, LispObj *constant, LispAtom *name) +{ + if (constant == NIL) + com_BytecodeAtom(com, XBC_LET_NIL, name); + else { + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = XBC_LOADCON_LET; + tree->data.let_con.object = constant; + tree->data.let_con.name = name; + } +} + +static void +com_LoadConPush(LispCom *com, LispObj *constant) +{ + if (constant == NIL) + com_Bytecode(com, XBC_PUSH_NIL); + else if (constant == T) + com_Bytecode(com, XBC_PUSH_T); + else if (constant == UNSPEC) + com_Bytecode(com, XBC_PUSH_UNSPEC); + else + com_BytecodeObject(com, XBC_LOADCON_PUSH, constant); +} + +static void +com_Set(LispCom *com, short offset) +{ + com_BytecodeShort(com, XBC_SET, offset); +} + +static void +com_SetSym(LispCom *com, LispAtom *symbol) +{ + com_BytecodeAtom(com, XBC_SETSYM, symbol); +} + +static void +com_Struct(LispCom *com, short offset, LispObj *definition) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = XBC_STRUCT; + tree->data.struc.offset = offset; + tree->data.struc.definition = definition; +} + +static void +com_Structp(LispCom *com, LispObj *definition) +{ + com_BytecodeObject(com, XBC_STRUCTP, definition); +} + +static void +com_Call(LispCom *com, unsigned char num_arguments, LispBuiltin *builtin) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = XBC_CALL; + tree->data.builtin.num_arguments = num_arguments; + tree->data.builtin.builtin = builtin; +} + +static void +com_Bytecall(LispCom *com, unsigned char num_arguments, LispObj *code) +{ + CodeTree *tree = NEW_TREE(CodeTreeBytecode); + + tree->code = XBC_BYTECALL; + tree->data.bytecall.num_arguments = num_arguments; + tree->data.bytecall.code = code; +} + +static void +com_Funcall(LispCom *com, LispObj *function, LispObj *arguments) +{ + com_BytecodeCons(com, XBC_FUNCALL, function, arguments); +} + +static void +CompileStackEnter(LispCom *com, int count, int builtin) +{ + if (!com->macro) { + if (builtin) { + com->stack.cbstack += count; + if (com->stack.bstack < com->stack.cbstack) + com->stack.bstack = com->stack.cbstack; + } + else { + com->stack.cstack += count; + if (com->stack.stack < com->stack.cstack) + com->stack.stack = com->stack.cstack; + } + } +} + +static void +CompileStackLeave(LispCom *com, int count, int builtin) +{ + if (!com->macro) { + if (builtin) + com->stack.cbstack -= count; + else + com->stack.cstack -= count; + } +} + +static void +LinkWarnUnused(LispCom *com, CodeBlock *block) +{ + int i; + CodeTree *tree; + + for (tree = block->tree; tree; tree = tree->next) { + if (tree->type == CodeTreeBlock) + LinkWarnUnused(com, tree->data.block); + } + + for (i = 0; i < block->variables.length; i++) + if (!(block->variables.flags[i] & (VARIABLE_USED | VARIABLE_ARGUMENT))) { + ++com->warnings; + LispWarning("the variable %s is unused", + block->variables.symbols[i]->string); + } +} + +#define INTERNAL_ERROR_STRING "COMPILE: internal error #%d" +#define INTERNAL_ERROR(value) LispDestroy(INTERNAL_ERROR_STRING, value) +static long +LinkBuildOffsets(LispCom *com, CodeTree *tree, long offset) +{ + for (; tree; tree = tree->next) { + tree->offset = offset; + switch (tree->type) { + case CodeTreeBytecode: + switch (tree->code) { + case XBC_NOOP: + INTERNAL_ERROR(__LINE__); + break; + + /* byte */ + case XBC_BCONS: + case XBC_BCONS1: + case XBC_BCONS2: + case XBC_BCONS3: + case XBC_BCONS4: + case XBC_BCONS5: + case XBC_BCONS6: + case XBC_BCONS7: + case XBC_INV: + case XBC_NIL: + case XBC_T: + case XBC_PUSH: + case XBC_CAR_PUSH: + case XBC_CDR_PUSH: + case XBC_PUSH_NIL: + case XBC_PUSH_UNSPEC: + case XBC_PUSH_T: + case XBC_LSTAR: + case XBC_LCONS: + case XBC_LFINI: + case XBC_RETURN: + case XBC_CSTAR: + case XBC_CFINI: + case XBC_CAR: + case XBC_CDR: + case XBC_RPLACA: + case XBC_RPLACD: + case XBC_EQ: + case XBC_EQL: + case XBC_EQUAL: + case XBC_EQUALP: + case XBC_LENGTH: + case XBC_LAST: + case XBC_NTHCDR: + ++offset; + break; + + /* byte + byte */ + case XBC_PUSH_NIL_N: + case XBC_PUSH_UNSPEC_N: + case XBC_PRED: + case XBC_LETREC: + case XBC_LOAD_PUSH: + case XBC_CAR_SET: + case XBC_CDR_SET: + case XBC_SET: + case XBC_SET_NIL: + case XBC_LETBIND: + case XBC_UNLET: + case XBC_LOAD: + case XBC_LOAD_CAR: + case XBC_LOAD_CDR: + case XBC_LOAD_CAR_STORE: + case XBC_LOAD_CDR_STORE: + case XBC_LET: + case XBC_LETX: + case XBC_LET_NIL: + case XBC_LETX_NIL: + case XBC_STRUCTP: + case XBC_SETSYM: + case XBC_LOADCON_PUSH: + case XBC_LOADSYM_PUSH: + case XBC_LOADCON: + case XBC_LOADSYM: + offset += 2; + break; + + /* byte + byte + byte */ + case XBC_CALL: + case XBC_BYTECALL: + case XBC_LOAD_SET: + case XBC_LOAD_CAR_SET: + case XBC_LOAD_CDR_SET: + case XBC_LOADCON_SET: + case XBC_LOAD_LET: + case XBC_LOAD_LETX: + case XBC_STRUCT: + case XBC_LOADCON_LET: + case XBC_LOADCON_LETX: + case XBC_LOADSYM_LET: + case XBC_LOADSYM_LETX: + case XBC_CCONS: + case XBC_FUNCALL: + offset += 3; + break; + + /* byte + short */ + case XBC_JUMP: + case XBC_JUMPT: + case XBC_JUMPNIL: + /* XXX this is likely a jump to random address here */ + INTERNAL_ERROR(__LINE__); + offset += sizeof(short) + 1; + break; + + /* byte + byte + byte + byte */ + case XBC_CALL_SET: + offset += 4; + break; + } + break; + case CodeTreeLabel: + /* Labels are not loaded */ + break; + case CodeTreeJump: + case CodeTreeJumpIf: + case CodeTreeCond: + /* If not the point where the conditional block finishes */ + if (tree->code != XBC_NOOP) + /* Reserve space for the jump opcode */ + offset += sizeof(short) + 1; + break; + case CodeTreeGo: + case CodeTreeReturn: + /* Reserve space for the jump opcode */ + offset += sizeof(short) + 1; + break; + case CodeTreeBlock: + offset = LinkBuildOffsets(com, tree->data.block->tree, offset); + break; + } + } + + return (offset); +} + +static void +LinkDoOptimize_0(LispCom *com, CodeBlock *block) +{ + CodeTree *tree, *prev, *next; + + /* Remove redundant or join opcodes that can be joined. Do it here + * because some of these are hard to detect earlier, and/or would + * require a lot of duplicated code or more time. */ + tree = prev = block->tree; + while (tree) { + next = tree->next; + + /* LET -> LET* */ + if (next && + next->type == CodeTreeBytecode && + next->code == XBC_LETBIND && + next->data.signed_short == 1) { + switch (tree->code) { + case XBC_LET: + tree->code = XBC_LETX; + goto remove_next_label; + case XBC_LET_NIL: + tree->code = XBC_LETX_NIL; + goto remove_next_label; + case XBC_LOAD_LET: + tree->code = XBC_LOAD_LETX; + goto remove_next_label; + case XBC_LOADCON_LET: + tree->code = XBC_LOADCON_LETX; + goto remove_next_label; + case XBC_LOADSYM_LET: + tree->code = XBC_LOADSYM_LETX; + goto remove_next_label; + default: + break; + } + } + + switch (tree->type) { + case CodeTreeBytecode: + switch (tree->code) { + case XBC_LOADCON: + if (next && next->type == CodeTreeBytecode) { + switch (next->code) { + case XBC_LET: + next->code = XBC_LOADCON_LET; + next->data.let_con.name = + next->data.atom; + next->data.let_con.object = + tree->data.object; + goto remove_label; + case XBC_PUSH: + next->code = XBC_LOADCON_PUSH; + next->data.object = tree->data.object; + goto remove_label; + case XBC_CAR: + if (tree->data.object != NIL) { + if (!CONSP(tree->data.object)) + LispDestroy("CAR: %s is not a list", + STROBJ( + tree->data.object)); + next->code = XBC_LOADCON; + next->data.object = + CAR(tree->data.object); + } + goto remove_label; + case XBC_CDR: + if (tree->data.object != NIL) { + if (!CONSP(tree->data.object)) + LispDestroy("CAR: %s is not a list", + STROBJ( + tree->data.object)); + next->code = XBC_LOADCON; + next->data.object = + CDR(tree->data.object); + } + goto remove_label; + case XBC_SET: + next->code = XBC_LOADCON_SET; + next->data.load_con_set.offset = + next->data.signed_short; + next->data.load_con_set.object = + tree->data.object; + goto remove_label; + default: + break; + } + } + break; + case XBC_LOADSYM: + if (next && next->type == CodeTreeBytecode) { + switch (next->code) { + case XBC_LET: + next->code = XBC_LOADSYM_LET; + next->data.let_sym.name = + next->data.atom; + next->data.let_sym.symbol = + tree->data.atom; + goto remove_label; + case XBC_PUSH: + next->code = XBC_LOADSYM_PUSH; + next->data.atom = tree->data.atom; + goto remove_label; + default: + break; + } + } + break; + case XBC_LOAD: + if (next && next->type == CodeTreeBytecode) { + switch (next->code) { + case XBC_SET: + next->code = XBC_LOAD_SET; + next->data.load_set.set = + next->data.signed_short; + next->data.load_set.load = + tree->data.signed_short; + goto remove_label; + /* TODO add XBC_LOAD_SETSYM */ + case XBC_CAR: + next->code = XBC_LOAD_CAR; + next->data.signed_short = + tree->data.signed_short; + goto remove_label; + case XBC_CDR: + next->code = XBC_LOAD_CDR; + next->data.signed_short = + tree->data.signed_short; + goto remove_label; + case XBC_PUSH: + tree->code = XBC_LOAD_PUSH; + goto remove_next_label; + case XBC_LET: + next->code = XBC_LOAD_LET; + next->data.let.name = next->data.atom; + next->data.let.offset = + tree->data.signed_short; + goto remove_label; + default: + break; + } + } + break; + case XBC_LOAD_CAR: + if (next && next->type == CodeTreeBytecode && + next->code == XBC_SET) { + if (next->data.signed_short == + tree->data.signed_short) + next->code = XBC_LOAD_CAR_STORE; + else { + next->code = XBC_LOAD_CAR_SET; + next->data.load_set.set = + next->data.signed_short; + next->data.load_set.load = + tree->data.signed_short; + } + goto remove_label; + } + break; + case XBC_LOAD_CDR: + if (next && next->type == CodeTreeBytecode && + next->code == XBC_SET) { + if (next->data.signed_short == + tree->data.signed_short) + next->code = XBC_LOAD_CDR_STORE; + else { + next->code = XBC_LOAD_CDR_SET; + next->data.load_set.set = + next->data.signed_short; + next->data.load_set.load = + tree->data.signed_short; + } + goto remove_label; + } + break; + case XBC_CALL: + if (next && next->type == CodeTreeBytecode) { + switch (next->code) { + case XBC_SET: + next->code = XBC_CALL_SET; + next->data.builtin.offset = + next->data.signed_short; + next->data.builtin.num_arguments = + tree->data.builtin.num_arguments; + next->data.builtin.builtin = + tree->data.builtin.builtin; + goto remove_label; + /* TODO add XBC_CALL_SETSYM */ + default: + break; + } + } + break; + case XBC_CAR: + if (next && next->type == CodeTreeBytecode) { + switch (next->code) { + case XBC_SET: + next->code = XBC_CAR_SET; + goto remove_label; + /* TODO add XBC_CAR_SETSYM */ + case XBC_PUSH: + next->code = XBC_CAR_PUSH; + goto remove_label; + default: + break; + } + } + break; + case XBC_CDR: + if (next && next->type == CodeTreeBytecode) { + switch (next->code) { + case XBC_SET: + next->code = XBC_CDR_SET; + goto remove_label; + /* TODO add XBC_CDR_SETSYM */ + case XBC_PUSH: + next->code = XBC_CDR_PUSH; + goto remove_label; + default: + break; + } + } + break; + case XBC_NIL: + if (next && next->type == CodeTreeBytecode) { + switch (next->code) { + case XBC_SET: + next->code = XBC_SET_NIL; + goto remove_label; + /* TODO add XBC_SETSYM_NIL */ + default: + break; + } + } + break; + case XBC_PUSH_NIL: + if (next && next->type == CodeTreeBytecode && + next->code == XBC_PUSH_NIL) { + next->code = XBC_PUSH_NIL_N; + next->data.signed_char = 2; + goto remove_label; + } + break; + case XBC_PUSH_NIL_N: + if (next && next->type == CodeTreeBytecode && + next->code == XBC_PUSH_NIL) { + next->code = XBC_PUSH_NIL_N; + next->data.signed_char = tree->data.signed_char + 1; + goto remove_label; + } + break; + case XBC_PUSH_UNSPEC: + if (next && next->type == CodeTreeBytecode && + next->code == XBC_PUSH_UNSPEC) { + next->code = XBC_PUSH_UNSPEC_N; + next->data.signed_char = 2; + goto remove_label; + } + break; + case XBC_PUSH_UNSPEC_N: + if (next && next->type == CodeTreeBytecode && + next->code == XBC_PUSH_UNSPEC) { + next->code = XBC_PUSH_UNSPEC_N; + next->data.signed_char = tree->data.signed_char + 1; + goto remove_label; + } + break; + default: + break; + } + break; + case CodeTreeBlock: + LinkDoOptimize_0(com, tree->data.block); + break; + default: + break; + } + goto update_label; +remove_label: + if (tree == block->tree) { + block->tree = prev = next; + if (tree == block->tail) + block->tail = tree; + } + else + prev->next = next; + CompileFreeTree(tree); + tree = next; + continue; +remove_next_label: + tree->next = next->next; + CompileFreeTree(next); + continue; +update_label: + prev = tree; + tree = tree->next; + } +} + +static void +LinkOptimize_0(LispCom *com) +{ + /* Recursive */ + LinkDoOptimize_0(com, com->block); +} + +static void +LinkResolveLabels(LispCom *com, CodeBlock *block) +{ + int i; + CodeTree *tree = block->tree; + + for (; tree; tree = tree->next) { + if (tree->type == CodeTreeBlock) + LinkResolveLabels(com, tree->data.block); + else if (tree->type == CodeTreeLabel) { + for (i = 0; i < block->tagbody.length; i++) + if (tree->data.object == block->tagbody.labels[i]) { + block->tagbody.codes[i] = tree; + break; + } + } + } +} + +static void +LinkResolveJumps(LispCom *com, CodeBlock *block) +{ + int i; + CodeBlock *body = block; + CodeTree *ptr, *tree = block->tree; + + /* Check if there is a tagbody. Error checking already done */ + while (body && body->type != LispBlockBody) + body = body->prev; + + for (; tree; tree = tree->next) { + switch (tree->type) { + case CodeTreeBytecode: + case CodeTreeLabel: + break; + + case CodeTreeBlock: + LinkResolveJumps(com, tree->data.block); + break; + + case CodeTreeGo: + for (i = 0; i < body->tagbody.length; i++) + if (tree->data.object == body->tagbody.labels[i]) + break; + if (i == body->tagbody.length) + LispDestroy("COMPILE: no visible tag %s to GO", + STROBJ(tree->data.object)); + /* Now the jump code is known */ + tree->data.tree = body->tagbody.codes[i]; + break; + + case CodeTreeCond: + if (tree->code == XBC_JUMPNIL) + /* If test is NIL, go to next test */ + tree->data.tree = tree->group->next; + else if (tree->code == XBC_JUMPT) { + /* After executing code, test was T */ + for (ptr = tree->group; + ptr->code != XBC_NOOP; + ptr = ptr->group) + ; + tree->data.tree = ptr; + } + break; + + case CodeTreeJumpIf: + if (tree->code != XBC_NOOP) { + for (ptr = tree->group; + ptr->code != XBC_NOOP; + ptr = ptr->group) { + if (ptr->type == CodeTreeJump) { + /* ELSE code of IF */ + ptr = ptr->next; + /* Skip inconditional jump node */ + break; + } + } + tree->data.tree = ptr; + } + break; + + case CodeTreeJump: + if (tree->code != XBC_NOOP) + tree->data.tree = tree->group; + break; + + case CodeTreeReturn: + /* One bytecode is guaranteed to exist in the code tree */ + if (tree->data.block->parent == NULL) + /* Returning from the function or toplevel form */ + tree->data.tree = tree->data.block->tail; + else { + for (;;) { + ptr = tree->data.block->parent->next; + if (ptr) { + tree->data.tree = ptr; + break; + } + else + /* Move one BLOCK up */ + tree->data.block = tree->data.block->prev; + } + } + break; + } + } +} + +static long +LinkPad(long offset, long adjust, int preffix, int datalen) +{ + /* If byte or aligned data */ + if (datalen <= preffix || ((offset + adjust + preffix) % datalen) == 0) + return (adjust); + + return (adjust + (datalen - ((offset + adjust + preffix) % datalen))); +} + +static long +LinkFixupOffsets(LispCom *com, CodeTree *tree, long adjust) +{ + for (; tree; tree = tree->next) { + switch (tree->type) { + case CodeTreeBytecode: + switch (tree->code) { + /* byte + short */ + case XBC_JUMP: + case XBC_JUMPT: + case XBC_JUMPNIL: + adjust = LinkPad(tree->offset, adjust, 1, + sizeof(short)); + /*FALLTROUGH*/ + default: + tree->offset += adjust; + break; + } + break; + case CodeTreeLabel: + /* Labels are not loaded, just adjust offset */ + tree->offset += adjust; + break; + case CodeTreeJump: + case CodeTreeCond: + case CodeTreeJumpIf: + /* If an opcode will be generated. */ + if (tree->code != XBC_NOOP) + adjust = LinkPad(tree->offset, adjust, 1, sizeof(short)); + tree->offset += adjust; + break; + case CodeTreeGo: + case CodeTreeReturn: + adjust = LinkPad(tree->offset, adjust, 1, sizeof(short)); + tree->offset += adjust; + break; + case CodeTreeBlock: + adjust = LinkFixupOffsets(com, tree->data.block->tree, adjust); + break; + } + } + + return (adjust); +} + +static void +LinkSkipPadding(LispCom *com, CodeTree *tree) +{ + int found; + CodeTree *ptr; + + /* Recurse to adjust forward jumps or jumps to the start of the block */ + for (ptr = tree; ptr; ptr = ptr->next) { + if (ptr->type == CodeTreeBlock) { + LinkSkipPadding(com, ptr->data.block->tree); + ptr->offset = ptr->data.block->tree->offset; + } + } + + /* Adjust the nodes offsets */ + for (; tree; tree = tree->next) { + switch (tree->type) { + case CodeTreeBytecode: + case CodeTreeBlock: + case CodeTreeGo: + case CodeTreeReturn: + break; + case CodeTreeJump: + case CodeTreeCond: + case CodeTreeJumpIf: + if (tree->code != XBC_NOOP) + /* If code will be generated */ + break; + case CodeTreeLabel: + /* This should be done in reversed order, but to avoid + * the requirement of a prev pointer, do the job in a + * harder way here. */ + for (found = 0, ptr = tree->next; ptr; ptr = ptr->next) { + switch (ptr->type) { + case CodeTreeBytecode: + case CodeTreeBlock: + case CodeTreeGo: + case CodeTreeReturn: + found = 1; + break; + case CodeTreeJump: + case CodeTreeCond: + case CodeTreeJumpIf: + if (ptr->code != XBC_NOOP) + found = 1; + break; + case CodeTreeLabel: + break; + } + if (found) + break; + } + if (found) + tree->offset = ptr->offset; + break; + } + } +} + +static void +LinkCalculateJump(LispCom *com, CodeTree *tree, LispByteOpcode code) +{ + long jumpto, offset, distance; + + tree->type = CodeTreeBytecode; + /* After the opcode */ + offset = tree->offset + 1; + jumpto = tree->data.tree->offset; + /* Effective distance */ + distance = jumpto - offset; + tree->code = code; + if (distance < -32768 || distance > 32767) { + COMPILE_FAILURE("jump too long"); + } + tree->data.signed_int = distance; +} + +static void +LinkFixupJumps(LispCom *com, CodeTree *tree) +{ + for (; tree; tree = tree->next) { + switch (tree->type) { + case CodeTreeBytecode: + case CodeTreeLabel: + break; + case CodeTreeCond: + if (tree->code == XBC_JUMPNIL) + /* Go to next test if NIL */ + LinkCalculateJump(com, tree, XBC_JUMPNIL); + else if (tree->code == XBC_JUMPT) + /* After executing T code */ + LinkCalculateJump(com, tree, XBC_JUMP); + break; + case CodeTreeJumpIf: + if (tree->code != XBC_NOOP) + LinkCalculateJump(com, tree, tree->code); + break; + case CodeTreeGo: + /* Inconditional jump */ + LinkCalculateJump(com, tree, XBC_JUMP); + break; + case CodeTreeReturn: + /* Inconditional jump */ + if (tree->data.tree != tree) + /* If need to skip something */ + LinkCalculateJump(com, tree, XBC_JUMP); + break; + case CodeTreeBlock: + LinkFixupJumps(com, tree->data.block->tree); + break; + case CodeTreeJump: + if (tree->code != XBC_NOOP) + LinkCalculateJump(com, tree, tree->code); + } + } +} + +static void +LinkBuildTableSymbol(LispCom *com, LispAtom *symbol) +{ + if (BuildTablePointer(symbol, (void***)&com->table.symbols, + &com->table.num_symbols) > 0xff) { + COMPILE_FAILURE("more than 256 symbols"); + } +} + +static void +LinkBuildTableConstant(LispCom *com, LispObj *constant) +{ + if (BuildTablePointer(constant, (void***)&com->table.constants, + &com->table.num_constants) > 0xff) { + COMPILE_FAILURE("more than 256 constants"); + } +} + +static void +LinkBuildTableBuiltin(LispCom *com, LispBuiltin *builtin) +{ + if (BuildTablePointer(builtin, (void***)&com->table.builtins, + &com->table.num_builtins) > 0xff) { + COMPILE_FAILURE("more than 256 functions"); + } +} + +static void +LinkBuildTableBytecode(LispCom *com, LispObj *bytecode) +{ + if (BuildTablePointer(bytecode, (void***)&com->table.bytecodes, + &com->table.num_bytecodes) > 0xff) { + COMPILE_FAILURE("more than 256 bytecode functions"); + } +} + +static void +LinkBuildTables(LispCom *com, CodeBlock *block) +{ + CodeTree *tree; + + for (tree = block->tree; tree; tree = tree->next) { + switch (tree->type) { + case CodeTreeBytecode: + switch (tree->code) { + case XBC_LET: + case XBC_LETX: + case XBC_LET_NIL: + case XBC_LETX_NIL: + case XBC_SETSYM: + case XBC_LOADSYM: + case XBC_LOADSYM_PUSH: + LinkBuildTableSymbol(com, tree->data.atom); + break; + case XBC_STRUCTP: + case XBC_LOADCON: + case XBC_LOADCON_PUSH: + LinkBuildTableConstant(com, tree->data.object); + break; + case XBC_LOADCON_SET: + LinkBuildTableConstant(com, tree->data.load_con_set.object); + break; + case XBC_CALL: + case XBC_CALL_SET: + LinkBuildTableBuiltin(com, tree->data.builtin.builtin); + break; + case XBC_BYTECALL: + LinkBuildTableBytecode(com, tree->data.bytecall.code); + break; + case XBC_LOAD_LET: + case XBC_LOAD_LETX: + LinkBuildTableSymbol(com, tree->data.let.name); + break; + case XBC_STRUCT: + LinkBuildTableConstant(com, tree->data.struc.definition); + break; + case XBC_LOADSYM_LET: + case XBC_LOADSYM_LETX: + LinkBuildTableSymbol(com, tree->data.let_sym.symbol); + LinkBuildTableSymbol(com, tree->data.let_sym.name); + break; + case XBC_LOADCON_LET: + case XBC_LOADCON_LETX: + LinkBuildTableConstant(com, tree->data.let_con.object); + LinkBuildTableSymbol(com, tree->data.let_con.name); + break; + case XBC_CCONS: + case XBC_FUNCALL: + LinkBuildTableConstant(com, tree->data.cons.car); + LinkBuildTableConstant(com, tree->data.cons.cdr); + break; + default: + break; + } + break; + case CodeTreeBlock: + LinkBuildTables(com, tree->data.block); + break; + default: + break; + } + } +} + +static long +LinkEmmitBytecode(LispCom *com, CodeTree *tree, + unsigned char *bytecode, long offset) +{ + short i; + + for (; tree; tree = tree->next) { + /* Fill padding */ + while (offset < tree->offset) + bytecode[offset++] = XBC_NOOP; + + switch (tree->type) { + case CodeTreeBytecode: + bytecode[offset++] = tree->code; + switch (tree->code) { + /* Noop should not enter the CodeTree */ + case XBC_NOOP: + INTERNAL_ERROR(__LINE__); + break; + + /* byte */ + case XBC_BCONS: + case XBC_BCONS1: + case XBC_BCONS2: + case XBC_BCONS3: + case XBC_BCONS4: + case XBC_BCONS5: + case XBC_BCONS6: + case XBC_BCONS7: + case XBC_INV: + case XBC_NIL: + case XBC_T: + case XBC_PUSH_NIL: + case XBC_PUSH_UNSPEC: + case XBC_PUSH_T: + case XBC_CAR_PUSH: + case XBC_CDR_PUSH: + case XBC_PUSH: + case XBC_LSTAR: + case XBC_LCONS: + case XBC_LFINI: + case XBC_RETURN: + case XBC_CSTAR: + case XBC_CFINI: + case XBC_CAR: + case XBC_CDR: + case XBC_RPLACA: + case XBC_RPLACD: + case XBC_EQ: + case XBC_EQL: + case XBC_EQUAL: + case XBC_EQUALP: + case XBC_LENGTH: + case XBC_LAST: + case XBC_NTHCDR: + break; + + /* byte + byte */ + case XBC_LETREC: + case XBC_PRED: + case XBC_PUSH_NIL_N: + case XBC_PUSH_UNSPEC_N: + bytecode[offset++] = tree->data.signed_char; + break; + + /* byte + byte */ + case XBC_CAR_SET: + case XBC_CDR_SET: + case XBC_SET: + case XBC_SET_NIL: + case XBC_LETBIND: + case XBC_UNLET: + case XBC_LOAD_PUSH: + case XBC_LOAD: + case XBC_LOAD_CAR: + case XBC_LOAD_CDR: + case XBC_LOAD_CAR_STORE: + case XBC_LOAD_CDR_STORE: + bytecode[offset++] = tree->data.signed_short; + break; + + /* byte + byte + byte */ + case XBC_LOAD_SET: + case XBC_LOAD_CAR_SET: + case XBC_LOAD_CDR_SET: + bytecode[offset++] = tree->data.load_set.load; + bytecode[offset++] = tree->data.load_set.set; + break; + + /* byte + short */ + case XBC_JUMP: + case XBC_JUMPT: + case XBC_JUMPNIL: + *(short*)(bytecode + offset) = tree->data.signed_int; + offset += sizeof(short); + break; + + /* byte + byte */ + case XBC_LET: + case XBC_LETX: + case XBC_LET_NIL: + case XBC_LETX_NIL: + case XBC_SETSYM: + case XBC_LOADSYM: + case XBC_LOADSYM_PUSH: + i = FindIndex(tree->data.atom, + (void**)com->table.symbols, + com->table.num_symbols); + bytecode[offset++] = i; + break; + + /* byte + byte */ + case XBC_STRUCTP: + case XBC_LOADCON: + case XBC_LOADCON_PUSH: + i = FindIndex(tree->data.object, + (void**)com->table.constants, + com->table.num_constants); + bytecode[offset++] = i; + break; + + /* byte + byte + byte */ + case XBC_LOADCON_SET: + i = FindIndex(tree->data.load_con_set.object, + (void**)com->table.constants, + com->table.num_constants); + bytecode[offset++] = i; + bytecode[offset++] = tree->data.load_con_set.offset; + break; + + /* byte + byte + byte */ + case XBC_CALL: + bytecode[offset++] = tree->data.builtin.num_arguments; + i = FindIndex(tree->data.builtin.builtin, + (void**)com->table.builtins, + com->table.num_builtins); + bytecode[offset++] = i; + break; + + /* byte + byte + byte */ + case XBC_BYTECALL: + bytecode[offset++] = tree->data.bytecall.num_arguments; + i = FindIndex(tree->data.bytecall.code, + (void**)com->table.bytecodes, + com->table.num_bytecodes); + bytecode[offset++] = i; + break; + + /* byte + byte + byte + byte */ + case XBC_CALL_SET: + bytecode[offset++] = tree->data.builtin.num_arguments; + i = FindIndex(tree->data.builtin.builtin, + (void**)com->table.builtins, + com->table.num_builtins); + bytecode[offset++] = i; + bytecode[offset++] = tree->data.builtin.offset; + break; + + /* byte + byte + byte */ + case XBC_LOAD_LET: + case XBC_LOAD_LETX: + bytecode[offset++] = tree->data.let.offset; + i = FindIndex(tree->data.let.name, + (void**)com->table.symbols, + com->table.num_symbols); + bytecode[offset++] = i; + break; + + /* byte + byte + byte */ + case XBC_STRUCT: + bytecode[offset++] = tree->data.struc.offset; + i = FindIndex(tree->data.struc.definition, + (void**)com->table.constants, + com->table.num_constants); + bytecode[offset++] = i; + break; + + /* byte + byte + byte */ + case XBC_LOADSYM_LET: + case XBC_LOADSYM_LETX: + i = FindIndex(tree->data.let_sym.symbol, + (void**)com->table.symbols, + com->table.num_symbols); + bytecode[offset++] = i; + i = FindIndex(tree->data.let_sym.name, + (void**)com->table.symbols, + com->table.num_symbols); + bytecode[offset++] = i; + break; + + /* byte + byte + byte */ + case XBC_LOADCON_LET: + case XBC_LOADCON_LETX: + i = FindIndex(tree->data.let_con.object, + (void**)com->table.constants, + com->table.num_constants); + bytecode[offset++] = i; + i = FindIndex(tree->data.let_con.name, + (void**)com->table.symbols, + com->table.num_symbols); + bytecode[offset++] = i; + break; + + /* byte + byte + byte */ + case XBC_CCONS: + case XBC_FUNCALL: + i = FindIndex(tree->data.cons.car, + (void**)com->table.constants, + com->table.num_constants); + bytecode[offset++] = i; + i = FindIndex(tree->data.cons.cdr, + (void**)com->table.constants, + com->table.num_constants); + bytecode[offset++] = i; + break; + } + break; + case CodeTreeLabel: + /* Labels are not loaded */ + break; + case CodeTreeCond: + case CodeTreeJump: + case CodeTreeJumpIf: + if (tree->code != XBC_NOOP) + INTERNAL_ERROR(__LINE__); + break; + case CodeTreeGo: + INTERNAL_ERROR(__LINE__); + break; + case CodeTreeReturn: + if (tree->data.tree != tree) + INTERNAL_ERROR(__LINE__); + break; + case CodeTreeBlock: + offset = LinkEmmitBytecode(com, tree->data.block->tree, + bytecode, offset); + break; + } + } + + return (offset); +} + +static void +LinkBytecode(LispCom *com) +{ + long offset, count; + unsigned char **codes; + LispObj **names; + + /* Close bytecode */ + com_Bytecode(com, XBC_RETURN); + + /* The only usage of this information for now, and still may generate + * false positives because arguments to unamed functions are not being + * parsed as well as arguments to yet undefined function/maros. + * XXX should also add declaim/declare to let the code specify that + * the argument is unused */ + LinkWarnUnused(com, com->block); + + /* First level optimization */ + LinkOptimize_0(com); + + /* Resolve tagbody labels */ + LinkResolveLabels(com, com->block); + + /* Resolve any pending jumps */ + LinkResolveJumps(com, com->block); + + /* Calculate unpadded offsets */ + LinkBuildOffsets(com, com->block->tree, 0); + + /* Do padding for aligned memory reads */ + LinkFixupOffsets(com, com->block->tree, 0); + + /* Jumps normally are to a node that does not generate code, + * and due to padding, the jump may go to a address with a + * XBC_NOOP, so adjust the jump to the next useful opcode. */ + LinkSkipPadding(com, com->block->tree); + + /* Now addresses are known */ + LinkFixupJumps(com, com->block->tree); + + /* Build symbol, constant and builtin tables */ + LinkBuildTables(com, com->block); + + /* Stack info */ + com->length = sizeof(short) * 3; + /* Tables info */ + com->length += sizeof(short) * 4; + com->length += com->table.num_constants * sizeof(LispObj*); + com->length += com->table.num_symbols * sizeof(LispAtom*); + com->length += com->table.num_builtins * sizeof(LispBuiltin*); + com->length += com->table.num_bytecodes * sizeof(unsigned char*); + com->length += com->table.num_bytecodes * sizeof(LispObj*); + + /* Allocate space for the bytecode stream */ + com->length += com->block->tail->offset + 1; + com->bytecode = LispMalloc(com->length); + + /* Add header */ + offset = 0; + *(short*)(com->bytecode + offset) = com->stack.stack; + offset += sizeof(short); + *(short*)(com->bytecode + offset) = com->stack.bstack; + offset += sizeof(short); + *(short*)(com->bytecode + offset) = com->stack.pstack; + offset += sizeof(short); + + *(short*)(com->bytecode + offset) = com->table.num_constants; + offset += sizeof(short); + *(short*)(com->bytecode + offset) = com->table.num_symbols; + offset += sizeof(short); + *(short*)(com->bytecode + offset) = com->table.num_builtins; + offset += sizeof(short); + *(short*)(com->bytecode + offset) = com->table.num_bytecodes; + offset += sizeof(short); + + count = sizeof(LispObj*) * com->table.num_constants; + memcpy(com->bytecode + offset, com->table.constants, count); + offset += count; + count = sizeof(LispAtom*) * com->table.num_symbols; + memcpy(com->bytecode + offset, com->table.symbols, count); + offset += count; + count = sizeof(LispBuiltin*) * com->table.num_builtins; + memcpy(com->bytecode + offset, com->table.builtins, count); + offset += count; + + /* Store bytecode information */ + for (count = 0, codes = (unsigned char**)(com->bytecode + offset); + count < com->table.num_bytecodes; count++, codes++) + *codes = com->table.bytecodes[count]->data.bytecode.bytecode->code; + offset += com->table.num_bytecodes * sizeof(unsigned char*); + /* Store names, only useful for disassemble but may also be used + * to check if a function was redefined, and the bytecode is referencing + * the older version, the current version can be checked looking at + * <name>->data.atom */ + for (count = 0, names = (LispObj**)(com->bytecode + offset); + count < com->table.num_bytecodes; count++, names++) + *names = com->table.bytecodes[count]->data.bytecode.name; + offset += com->table.num_bytecodes * sizeof(LispObj*); + + /* Generate it */ + LinkEmmitBytecode(com, com->block->tree, com->bytecode + offset, 0); +} + +static LispObj * +ExecuteBytecode(register unsigned char *stream) +{ + register LispObj *reg0; + register LispAtom *atom; + register short offset; + LispObj *reg1; + LispBuiltin *builtin; + LispObj *lambda; + LispObj *arguments; + unsigned char *bytecode; + + LispObj **constants; + LispAtom **symbols; + LispBuiltin **builtins; + unsigned char **codes; + short num_constants, num_symbols, num_builtins, num_codes; + + int lex, len; + + /* To control gc protected slots */ + int phead, pbase; + + long fixnum = 0; + +#if defined(__GNUC__) && !defined(ANSI_SOURCE) +#define ALLOW_GOTO_ADDRESS +#endif + +#ifdef ALLOW_GOTO_ADDRESS +#define JUMP_ADDRESS(label) &&label + static const void *opcode_labels[] = { + JUMP_ADDRESS(XBC_NOOP), + JUMP_ADDRESS(XBC_INV), + JUMP_ADDRESS(XBC_NIL), + JUMP_ADDRESS(XBC_T), + JUMP_ADDRESS(XBC_PRED), + JUMP_ADDRESS(XBC_CAR), + JUMP_ADDRESS(XBC_CDR), + JUMP_ADDRESS(XBC_CAR_SET), + JUMP_ADDRESS(XBC_CDR_SET), + JUMP_ADDRESS(XBC_RPLACA), + JUMP_ADDRESS(XBC_RPLACD), + JUMP_ADDRESS(XBC_EQ), + JUMP_ADDRESS(XBC_EQL), + JUMP_ADDRESS(XBC_EQUAL), + JUMP_ADDRESS(XBC_EQUALP), + JUMP_ADDRESS(XBC_LENGTH), + JUMP_ADDRESS(XBC_LAST), + JUMP_ADDRESS(XBC_NTHCDR), + JUMP_ADDRESS(XBC_CAR_PUSH), + JUMP_ADDRESS(XBC_CDR_PUSH), + JUMP_ADDRESS(XBC_PUSH), + JUMP_ADDRESS(XBC_PUSH_NIL), + JUMP_ADDRESS(XBC_PUSH_UNSPEC), + JUMP_ADDRESS(XBC_PUSH_T), + JUMP_ADDRESS(XBC_PUSH_NIL_N), + JUMP_ADDRESS(XBC_PUSH_UNSPEC_N), + JUMP_ADDRESS(XBC_LET), + JUMP_ADDRESS(XBC_LETX), + JUMP_ADDRESS(XBC_LET_NIL), + JUMP_ADDRESS(XBC_LETX_NIL), + JUMP_ADDRESS(XBC_LETBIND), + JUMP_ADDRESS(XBC_UNLET), + JUMP_ADDRESS(XBC_LOAD), + JUMP_ADDRESS(XBC_LOAD_LET), + JUMP_ADDRESS(XBC_LOAD_LETX), + JUMP_ADDRESS(XBC_LOAD_PUSH), + JUMP_ADDRESS(XBC_LOADCON), + JUMP_ADDRESS(XBC_LOADCON_LET), + JUMP_ADDRESS(XBC_LOADCON_LETX), + JUMP_ADDRESS(XBC_LOADCON_PUSH), + JUMP_ADDRESS(XBC_LOAD_CAR), + JUMP_ADDRESS(XBC_LOAD_CDR), + JUMP_ADDRESS(XBC_LOAD_CAR_STORE), + JUMP_ADDRESS(XBC_LOAD_CDR_STORE), + JUMP_ADDRESS(XBC_LOADCON_SET), + JUMP_ADDRESS(XBC_LOADSYM), + JUMP_ADDRESS(XBC_LOADSYM_LET), + JUMP_ADDRESS(XBC_LOADSYM_LETX), + JUMP_ADDRESS(XBC_LOADSYM_PUSH), + JUMP_ADDRESS(XBC_LOAD_SET), + JUMP_ADDRESS(XBC_LOAD_CAR_SET), + JUMP_ADDRESS(XBC_LOAD_CDR_SET), + JUMP_ADDRESS(XBC_SET), + JUMP_ADDRESS(XBC_SETSYM), + JUMP_ADDRESS(XBC_SET_NIL), + JUMP_ADDRESS(XBC_CALL), + JUMP_ADDRESS(XBC_CALL_SET), + JUMP_ADDRESS(XBC_BYTECALL), + JUMP_ADDRESS(XBC_FUNCALL), + JUMP_ADDRESS(XBC_LETREC), + JUMP_ADDRESS(XBC_BCONS), + JUMP_ADDRESS(XBC_BCONS1), + JUMP_ADDRESS(XBC_BCONS2), + JUMP_ADDRESS(XBC_BCONS3), + JUMP_ADDRESS(XBC_BCONS4), + JUMP_ADDRESS(XBC_BCONS5), + JUMP_ADDRESS(XBC_BCONS6), + JUMP_ADDRESS(XBC_BCONS7), + JUMP_ADDRESS(XBC_CCONS), + JUMP_ADDRESS(XBC_CSTAR), + JUMP_ADDRESS(XBC_CFINI), + JUMP_ADDRESS(XBC_LSTAR), + JUMP_ADDRESS(XBC_LCONS), + JUMP_ADDRESS(XBC_LFINI), + JUMP_ADDRESS(XBC_JUMP), + JUMP_ADDRESS(XBC_JUMPT), + JUMP_ADDRESS(XBC_JUMPNIL), + JUMP_ADDRESS(XBC_STRUCT), + JUMP_ADDRESS(XBC_STRUCTP), + JUMP_ADDRESS(XBC_RETURN) + }; + static const void *predicate_opcode_labels[] = { + JUMP_ADDRESS(XBP_CONSP), + JUMP_ADDRESS(XBP_LISTP), + JUMP_ADDRESS(XBP_NUMBERP) + }; +#endif + + reg0 = NIL; + + bytecode = stream; + pbase = lisp__data.protect.length; + + /* stack */ + offset = *(short*)stream; + stream += sizeof(short); + if (lisp__data.env.length + offset > lisp__data.env.space) { + do + LispMoreEnvironment(); + while (lisp__data.env.length + offset >= lisp__data.env.space); + } + /* builtin stack */ + offset = *(short*)stream; + stream += sizeof(short); + if (lisp__data.stack.length + offset >= lisp__data.stack.space) { + do + LispMoreStack(); + while (lisp__data.stack.length + offset >= lisp__data.stack.space); + } + /* protect stack */ + phead = *(short*)stream; + stream += sizeof(short); + if (lisp__data.protect.length + phead > lisp__data.protect.space) { + do + LispMoreProtects(); + while (lisp__data.protect.length + phead >= lisp__data.protect.space); + } + + num_constants = *(short*)stream; + stream += sizeof(short); + num_symbols = *(short*)stream; + stream += sizeof(short); + num_builtins = *(short*)stream; + stream += sizeof(short); + num_codes = *(short*)stream; + stream += sizeof(short); + + constants = (LispObj**)stream; + stream += num_constants * sizeof(LispObj*); + symbols = (LispAtom**)stream; + stream += num_symbols * sizeof(LispAtom*); + builtins = (LispBuiltin**)stream; + stream += num_builtins * sizeof(LispBuiltin*); + codes = (unsigned char**)stream; + stream += num_codes * (sizeof(unsigned char*) + sizeof(LispObj*)); + + for (; phead > 0; phead--) + lisp__data.protect.objects[lisp__data.protect.length++] = NIL; + phead = pbase; + +#ifdef ALLOW_GOTO_ADDRESS +#define OPCODE_LABEL(label) label +#define NEXT_OPCODE() goto *opcode_labels[*stream++] +#define GOTO_PREDICATE() goto *predicate_opcode_labels[*stream++] +#else +#define OPCODE_LABEL(label) case label +#define NEXT_OPCODE() goto next_opcode +#define GOTO_PREDICATE() goto predicate_label + for (;;) { +next_opcode: + switch (*stream++) { +#endif /* ALLOW_GOTO_ADDRESS */ + +OPCODE_LABEL(XBC_NOOP): + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_PRED): + GOTO_PREDICATE(); + +OPCODE_LABEL(XBC_INV): + reg0 = reg0 == NIL ? T : NIL; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_NIL): + reg0 = NIL; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_T): + reg0 = T; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_CAR): +car: + if (reg0 != NIL) { + if (!CONSP(reg0)) + LispDestroy("CAR: %s is not a list", STROBJ(reg0)); + reg0 = CAR(reg0); + } + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_CDR): +cdr: + if (reg0 != NIL) { + if (!CONSP(reg0)) + LispDestroy("CDR: %s is not a list", STROBJ(reg0)); + reg0 = CDR(reg0); + } + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_RPLACA): + reg1 = lisp__data.stack.values[--lisp__data.stack.length]; + if (!CONSP(reg1)) + LispDestroy("RPLACA: %s is not a cons", STROBJ(reg1)); + RPLACA(reg1, reg0); + reg0 = reg1; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_RPLACD): + reg1 = lisp__data.stack.values[--lisp__data.stack.length]; + if (!CONSP(reg1)) + LispDestroy("RPLACD: %s is not a cons", STROBJ(reg1)); + RPLACD(reg1, reg0); + reg0 = reg1; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_BCONS): + CAR(cons) = reg0; + lisp__data.stack.values[lisp__data.stack.length++] = cons; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_BCONS1): + offset = lisp__data.stack.length - 1; + CAR(cons) = reg0; + CAR(cons1) = lisp__data.stack.values[offset]; + lisp__data.stack.values[offset] = cons1; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_BCONS2): + offset = lisp__data.stack.length; + CAR(cons) = reg0; + CAR(cons1) = lisp__data.stack.values[--offset]; + CAR(cons2) = lisp__data.stack.values[--offset]; + lisp__data.stack.values[offset] = cons2; + lisp__data.stack.length = offset + 1; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_BCONS3): + offset = lisp__data.stack.length; + CAR(cons) = reg0; + CAR(cons1) = lisp__data.stack.values[--offset]; + CAR(cons2) = lisp__data.stack.values[--offset]; + CAR(cons3) = lisp__data.stack.values[--offset]; + lisp__data.stack.values[offset] = cons3; + lisp__data.stack.length = offset + 1; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_BCONS4): + offset = lisp__data.stack.length; + CAR(cons) = reg0; + CAR(cons1) = lisp__data.stack.values[--offset]; + CAR(cons2) = lisp__data.stack.values[--offset]; + CAR(cons3) = lisp__data.stack.values[--offset]; + CAR(cons4) = lisp__data.stack.values[--offset]; + lisp__data.stack.values[offset] = cons4; + lisp__data.stack.length = offset + 1; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_BCONS5): + offset = lisp__data.stack.length; + CAR(cons) = reg0; + CAR(cons1) = lisp__data.stack.values[--offset]; + CAR(cons2) = lisp__data.stack.values[--offset]; + CAR(cons3) = lisp__data.stack.values[--offset]; + CAR(cons4) = lisp__data.stack.values[--offset]; + CAR(cons5) = lisp__data.stack.values[--offset]; + lisp__data.stack.values[offset] = cons5; + lisp__data.stack.length = offset + 1; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_BCONS6): + offset = lisp__data.stack.length; + CAR(cons) = reg0; + CAR(cons1) = lisp__data.stack.values[--offset]; + CAR(cons2) = lisp__data.stack.values[--offset]; + CAR(cons3) = lisp__data.stack.values[--offset]; + CAR(cons4) = lisp__data.stack.values[--offset]; + CAR(cons5) = lisp__data.stack.values[--offset]; + CAR(cons6) = lisp__data.stack.values[--offset]; + lisp__data.stack.values[offset] = cons6; + lisp__data.stack.length = offset + 1; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_BCONS7): + offset = lisp__data.stack.length; + CAR(cons) = reg0; + CAR(cons1) = lisp__data.stack.values[--offset]; + CAR(cons2) = lisp__data.stack.values[--offset]; + CAR(cons3) = lisp__data.stack.values[--offset]; + CAR(cons4) = lisp__data.stack.values[--offset]; + CAR(cons5) = lisp__data.stack.values[--offset]; + CAR(cons6) = lisp__data.stack.values[--offset]; + CAR(cons7) = lisp__data.stack.values[--offset]; + lisp__data.stack.values[offset] = cons7; + lisp__data.stack.length = offset + 1; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_EQ): + reg0 = reg0 == lisp__data.stack.values[--lisp__data.stack.length] ? T : NIL; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_EQL): + reg1 = lisp__data.stack.values[--lisp__data.stack.length]; + reg0 = XEQL(reg1, reg0); + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_EQUAL): + reg1 = lisp__data.stack.values[--lisp__data.stack.length]; + reg0 = XEQUAL(reg1, reg0); + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_EQUALP): + reg1 = lisp__data.stack.values[--lisp__data.stack.length]; + reg0 = XEQUALP(reg1, reg0); + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LENGTH): + reg0 = FIXNUM(LispLength(reg0)); + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LAST): + { + long length; + + reg1 = lisp__data.stack.values[--lisp__data.stack.length]; + if (CONSP(reg1)) { + if (reg0 != NIL) { + if (!FIXNUMP(reg0) || (fixnum = FIXNUM_VALUE(reg0)) < 0) + LispDestroy("LAST: %s is not a positive fixnum", + STROBJ(reg0)); + } + else + fixnum = 1; + reg0 = reg1; + for (reg0 = reg1, length = 0; + CONSP(reg0); + reg0 = CDR(reg0), length++) + ; + for (length -= fixnum, reg0 = reg1; length > 0; length--) + reg0 = CDR(reg0); + } + else + reg0 = reg1; + } NEXT_OPCODE(); + +OPCODE_LABEL(XBC_NTHCDR): + reg1 = lisp__data.stack.values[--lisp__data.stack.length]; + if (!FIXNUMP(reg1) || (fixnum = FIXNUM_VALUE(reg1)) < 0) + LispDestroy("NTHCDR: %s is not a positive fixnum", + STROBJ(reg1)); + if (reg0 != NIL) { + if (!CONSP(reg0)) + LispDestroy("NTHCDR: %s is not a list", STROBJ(reg0)); + for (; fixnum > 0; fixnum--) { + if (!CONSP(reg0)) + break; + reg0 = CDR(reg0); + } + } + NEXT_OPCODE(); + + /* Push to builtin stack */ +OPCODE_LABEL(XBC_CAR_PUSH): + if (reg0 != NIL) { + if (!CONSP(reg0)) + LispDestroy("CAR: %s is not a list", STROBJ(reg0)); + reg0 = CAR(reg0); + } + goto push_builtin; + +OPCODE_LABEL(XBC_CDR_PUSH): + if (reg0 != NIL) { + if (!CONSP(reg0)) + LispDestroy("CDR: %s is not a list", STROBJ(reg0)); + reg0 = CDR(reg0); + } + /*FALLTROUGH*/ + +OPCODE_LABEL(XBC_PUSH): +push_builtin: + lisp__data.stack.values[lisp__data.stack.length++] = reg0; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_PUSH_NIL): + lisp__data.stack.values[lisp__data.stack.length++] = NIL; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_PUSH_UNSPEC): + lisp__data.stack.values[lisp__data.stack.length++] = UNSPEC; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_PUSH_T): + lisp__data.stack.values[lisp__data.stack.length++] = T; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_PUSH_NIL_N): + for (offset = *stream++; offset > 0; offset--) + lisp__data.stack.values[lisp__data.stack.length++] = NIL; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_PUSH_UNSPEC_N): + for (offset = *stream++; offset > 0; offset--) + lisp__data.stack.values[lisp__data.stack.length++] = UNSPEC; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LET): +let_argument: + /* The global object value is not changed, so it does not + * matter if it is a constant symbol. An error would be + * generated if it was declared as constant at the time of + * bytecode generation. Check can be done looking at the + * atom->constant field. */ + atom = symbols[*stream++]; + atom->offset = lisp__data.env.length; + lisp__data.env.names[lisp__data.env.length] = atom->string; + lisp__data.env.values[lisp__data.env.length++] = reg0; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LETX): +letx_argument: + atom = symbols[*stream++]; + atom->offset = lisp__data.env.length; + lisp__data.env.names[lisp__data.env.length] = atom->string; + lisp__data.env.values[lisp__data.env.length++] = reg0; + lisp__data.env.head++; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LET_NIL): + atom = symbols[*stream++]; + atom->offset = lisp__data.env.length; + lisp__data.env.names[lisp__data.env.length] = atom->string; + lisp__data.env.values[lisp__data.env.length++] = NIL; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LETX_NIL): + atom = symbols[*stream++]; + atom->offset = lisp__data.env.length; + lisp__data.env.names[lisp__data.env.length] = atom->string; + lisp__data.env.values[lisp__data.env.length++] = NIL; + lisp__data.env.head++; + NEXT_OPCODE(); + + /* Bind locally added variables to a block */ +OPCODE_LABEL(XBC_LETBIND): + offset = *stream++; + lisp__data.env.head += offset; + NEXT_OPCODE(); + + /* Unbind locally added variables to a block */ +OPCODE_LABEL(XBC_UNLET): + offset = *stream++; + lisp__data.env.head -= offset; + lisp__data.env.length -= offset; + NEXT_OPCODE(); + + /* Load value from stack */ +OPCODE_LABEL(XBC_LOAD): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LOAD_CAR): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + goto car; + +OPCODE_LABEL(XBC_LOAD_CDR): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + goto cdr; + +OPCODE_LABEL(XBC_LOAD_CAR_STORE): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + if (reg0 != NIL) { + if (!CONSP(reg0)) + LispDestroy("CAR: %s is not a list", STROBJ(reg0)); + reg0 = CAR(reg0); + lisp__data.env.values[lisp__data.env.lex + offset] = reg0; + } + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LOAD_CDR_STORE): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + if (reg0 != NIL) { + if (!CONSP(reg0)) + LispDestroy("CDR: %s is not a list", STROBJ(reg0)); + reg0 = CDR(reg0); + lisp__data.env.values[lisp__data.env.lex + offset] = reg0; + } + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LOAD_LET): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + goto let_argument; + +OPCODE_LABEL(XBC_LOAD_LETX): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + goto letx_argument; + +OPCODE_LABEL(XBC_LOAD_PUSH): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + lisp__data.stack.values[lisp__data.stack.length++] = reg0; + NEXT_OPCODE(); + + /* Load pointer to constant */ +OPCODE_LABEL(XBC_LOADCON): + reg0 = constants[*stream++]; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LOADCON_LET): + reg0 = constants[*stream++]; + goto let_argument; + +OPCODE_LABEL(XBC_LOADCON_LETX): + reg0 = constants[*stream++]; + goto letx_argument; + +OPCODE_LABEL(XBC_LOADCON_PUSH): + reg0 = constants[*stream++]; + lisp__data.stack.values[lisp__data.stack.length++] = reg0; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LOADCON_SET): + reg0 = constants[*stream++]; + offset = *stream++; + lisp__data.env.values[lisp__data.env.lex + offset] = reg0; + NEXT_OPCODE(); + + /* Change value of local variable */ +OPCODE_LABEL(XBC_CAR_SET): +car_set: + if (reg0 != NIL) { + if (!CONSP(reg0)) + LispDestroy("CAR: %s is not a list", STROBJ(reg0)); + reg0 = CAR(reg0); + } + goto set_local_variable; + +OPCODE_LABEL(XBC_CDR_SET): +cdr_set: + if (reg0 != NIL) { + if (!CONSP(reg0)) + LispDestroy("CDR: %s is not a list", STROBJ(reg0)); + reg0 = CDR(reg0); + } + goto set_local_variable; + +OPCODE_LABEL(XBC_LOAD_CAR_SET): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + goto car_set; + +OPCODE_LABEL(XBC_LOAD_CDR_SET): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + goto cdr_set; + +OPCODE_LABEL(XBC_LOAD_SET): + offset = *stream++; + reg0 = lisp__data.env.values[lisp__data.env.lex + offset]; + /*FALLTROUGH*/ + +OPCODE_LABEL(XBC_SET): +set_local_variable: + offset = *stream++; + lisp__data.env.values[lisp__data.env.lex + offset] = reg0; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_SET_NIL): + offset = *stream++; + lisp__data.env.values[lisp__data.env.lex + offset] = NIL; + NEXT_OPCODE(); + + /* Change value of a global/special variable */ +OPCODE_LABEL(XBC_SETSYM): + atom = symbols[*stream++]; + if (atom->dyn) { + /* atom->dyn and atom->constant are exclusive, no + * need to check if variable declared as constant. */ + if (atom->offset < lisp__data.env.head && + lisp__data.env.names[atom->offset] == atom->string) + lisp__data.env.values[atom->offset] = reg0; + else { + if (atom->watch) + LispSetAtomObjectProperty(atom, reg0); + else + SETVALUE(atom, reg0); + } + } + else if (atom->a_object) { + if (atom->constant) + LispDestroy("EVAL: %s is a constant", + STROBJ(atom->object)); + else if (atom->watch) + LispSetAtomObjectProperty(atom, reg0); + else + SETVALUE(atom, reg0); + } + else { + /* Create new global variable */ + LispPackage *pack; + + LispWarning("the variable %s was not declared", + atom->string); + LispSetAtomObjectProperty(atom, reg0); + pack = atom->package->data.package.package; + if (pack->glb.length >= pack->glb.space) + LispMoreGlobals(pack); + pack->glb.pairs[pack->glb.length++] = atom->object; + } + NEXT_OPCODE(); + +/* Resolve symbol value at runtime */ +#define LOAD_SYMBOL_VALUE() \ + atom = symbols[*stream++]; \ + if (atom->dyn) { \ + if (atom->offset < lisp__data.env.head && \ + lisp__data.env.names[atom->offset] == atom->string) \ + reg0 = lisp__data.env.values[atom->offset]; \ + else { \ + reg0 = atom->property->value; \ + if (reg0 == UNBOUND) \ + LispDestroy("EVAL: the symbol %s is unbound", \ + STROBJ(atom->object)); \ + } \ + } \ + else { \ + if (atom->a_object) \ + reg0 = atom->property->value; \ + else \ + LispDestroy("EVAL: the symbol %s is unbound", \ + STROBJ(atom->object)); \ + } + +OPCODE_LABEL(XBC_LOADSYM): + LOAD_SYMBOL_VALUE(); + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LOADSYM_LET): + LOAD_SYMBOL_VALUE(); + goto let_argument; + +OPCODE_LABEL(XBC_LOADSYM_LETX): + LOAD_SYMBOL_VALUE(); + goto letx_argument; + +OPCODE_LABEL(XBC_LOADSYM_PUSH): + LOAD_SYMBOL_VALUE(); + lisp__data.stack.values[lisp__data.stack.length++] = reg0; + NEXT_OPCODE(); + + /* Builtin function */ +OPCODE_LABEL(XBC_CALL): + offset = *stream++; + lisp__data.stack.base = lisp__data.stack.length - offset; + builtin = builtins[*stream++]; + if (builtin->multiple_values) { + RETURN_COUNT = 0; + reg0 = builtin->function(builtin); + } + else { + reg0 = builtin->function(builtin); + RETURN_COUNT = 0; + } + lisp__data.stack.length -= offset; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_CALL_SET): + offset = *stream++; + lisp__data.stack.base = lisp__data.stack.length - offset; + builtin = builtins[*stream++]; + if (builtin->multiple_values) { + RETURN_COUNT = 0; + reg0 = builtin->function(builtin); + } + else { + reg0 = builtin->function(builtin); + RETURN_COUNT = 0; + } + lisp__data.stack.length -= offset; + offset = *stream++; + lisp__data.env.values[lisp__data.env.lex + offset] = reg0; + NEXT_OPCODE(); + + /* Bytecode call */ +OPCODE_LABEL(XBC_BYTECALL): + lex = lisp__data.env.lex; + offset = *stream++; + lisp__data.env.head = lisp__data.env.length; + len = lisp__data.env.lex = lisp__data.env.length - offset; + reg0 = ExecuteBytecode(codes[*stream++]); + lisp__data.env.length = lisp__data.env.head = len; + lisp__data.env.lex = lex; + NEXT_OPCODE(); + + /* Unimplemented function/macro call */ +OPCODE_LABEL(XBC_FUNCALL): + lambda = constants[*stream++]; + arguments = constants[*stream++]; + reg0 = LispFuncall(lambda, arguments, 1); + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_JUMP): + stream += *(signed short*)stream; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_JUMPT): + if (reg0 != NIL) + stream += *(signed short*)stream; + else + /* skip jump relative offset */ + stream += sizeof(signed short); + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_JUMPNIL): + if (reg0 == NIL) + stream += *(signed short*)stream; + else + /* skip jump relative offset */ + stream += sizeof(signed short); + NEXT_OPCODE(); + + /* Build CONS of two constant arguments */ +OPCODE_LABEL(XBC_CCONS): + reg0 = constants[*stream++]; + reg1 = constants[*stream++]; + reg0 = CONS(reg0, reg1); + NEXT_OPCODE(); + + /* Start CONS */ +OPCODE_LABEL(XBC_CSTAR): + /* This the CAR of the CONS */ + lisp__data.protect.objects[phead++] = reg0; + NEXT_OPCODE(); + + /* Finish CONS */ +OPCODE_LABEL(XBC_CFINI): + reg0 = CONS(lisp__data.protect.objects[--phead], reg0); + NEXT_OPCODE(); + + /* Start building list */ +OPCODE_LABEL(XBC_LSTAR): + reg1 = CONS(reg0, NIL); + /* Start of list stored here */ + lisp__data.protect.objects[phead++] = reg1; + /* Tail of list stored here */ + lisp__data.protect.objects[phead++] = reg1; + NEXT_OPCODE(); + + /* Add to list */ +OPCODE_LABEL(XBC_LCONS): + reg1 = lisp__data.protect.objects[phead - 2]; + RPLACD(reg1, CONS(reg0, NIL)); + lisp__data.protect.objects[phead - 2] = CDR(reg1); + NEXT_OPCODE(); + + /* Finish list */ +OPCODE_LABEL(XBC_LFINI): + phead -= 2; + reg0 = lisp__data.protect.objects[phead + 1]; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_STRUCT): + offset = *stream++; + reg1 = constants[*stream++]; + if (!STRUCTP(reg0) || reg0->data.struc.def != reg1) { + char *name = ATOMID(CAR(reg1)); + + for (reg1 = CDR(reg1); offset; offset--) + reg1 = CDR(reg1); + LispDestroy("%s-%s: %s is not a %s", + name, ATOMID(CAR(reg1)), STROBJ(reg0), name); + } + for (reg0 = reg0->data.struc.fields; offset; offset--) + reg0 = CDR(reg0); + reg0 = CAR(reg0); + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_STRUCTP): + reg1 = constants[*stream++]; + reg0 = STRUCTP(reg0) && reg0->data.struc.def == reg1 ? T : NIL; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_LETREC): + /* XXX could/should optimize, shouldn't need to parse + * the bytecode header again */ + lex = lisp__data.env.lex; + offset = *stream++; + lisp__data.env.head = lisp__data.env.length; + len = lisp__data.env.lex = lisp__data.env.length - offset; + reg0 = ExecuteBytecode(bytecode); + lisp__data.env.length = lisp__data.env.head = len; + lisp__data.env.lex = lex; + NEXT_OPCODE(); + +OPCODE_LABEL(XBC_RETURN): + lisp__data.protect.length = pbase; + return (reg0); + +#ifndef ALLOW_GOTO_ADDRESS + } /* end of switch */ + +predicate_label: + switch (*stream++) { +#endif + +OPCODE_LABEL(XBP_CONSP): + reg0 = CONSP(reg0) ? T : NIL; + NEXT_OPCODE(); + +OPCODE_LABEL(XBP_LISTP): + reg0 = LISTP(reg0) ? T : NIL; + NEXT_OPCODE(); + +OPCODE_LABEL(XBP_NUMBERP): + reg0 = NUMBERP(reg0) ? T : NIL; + NEXT_OPCODE(); + +#ifndef ALLOW_GOTO_ADDRESS + } /* end of switch */ + } +#endif + + /*NOTREACHED*/ + return (reg0); +} |