From 53ebe37f0445f1a132bd20729d41894c6470622a Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Tue, 21 Sep 2010 19:32:26 +0000 Subject: initial commit of Ozgur Dogan Ugurlu's (SF user:dogeen) assembler for the Tcl bytecode language --- ChangeLog | 16 + generic/tclAssembly.c | 1537 +++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclAssembly.h | 83 +++ generic/tclBasic.c | 9 +- generic/tclInt.h | 15 +- tests/assemble.test | 516 +++++++++++++++++ tests/assemble1.bench | 60 ++ unix/Makefile.in | 11 +- win/Makefile.in | 3 +- win/makefile.vc | 3 +- 10 files changed, 2247 insertions(+), 6 deletions(-) create mode 100644 generic/tclAssembly.c create mode 100644 generic/tclAssembly.h create mode 100644 tests/assemble.test create mode 100644 tests/assemble1.bench diff --git a/ChangeLog b/ChangeLog index 700f8f1..1d734fe 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,19 @@ +2010-09-21 Kevin B. Kenny + + [BRANCH: dogeen-assembler-branch] + + * generic/tclAssembly.c (new file): + * generic/tclAssembly.h: + * generic/tclBasic.c (builtInCmds, Tcl_CreateInterp): + * generic/tclInt.h: + * tests/assemble.test (new file): + * tests/assemble1.bench (new file): + * unix/Makefile.in: + * win/Makefile.in: + * win/Makefile.vc: + Initial commit of Ozgur Dogan Ugurlu's (SF user: dogeen) + assembler for the Tcl bytecode language. + 2010-09-20 Jan Nijtmans * win/tclWinFCmd.c: Eliminate tclWinProcs->useWide everywhere, since diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c new file mode 100644 index 0000000..7063b8a --- /dev/null +++ b/generic/tclAssembly.c @@ -0,0 +1,1537 @@ +#include "tclInt.h" +#include "tclCompile.h" +#include "tclAssembly.h" +#include "tclOOInt.h" + +/* Static functions defined in this file */ + +static void AddBasicBlockRangeToErrorInfo(Tcl_Interp* interp, Tcl_Obj* bcList, + BasicBlock* bbPtr); +static void AddInstructionToErrorInfo(Tcl_Interp* interp, Tcl_Obj* bcList, + int index); +static BasicBlock * AllocBB(CompileEnv*, int); +static int CheckNamespaceQualifiers(Tcl_Interp*, const char*); +static int CheckOneByte(Tcl_Interp*, int); +static int CheckSignedOneByte(Tcl_Interp*, int); +static int StackCheckBasicBlock(StackCheckerState* , BasicBlock *, BasicBlock *, int); +static BasicBlock* StartBasicBlock(CompileEnv* envPtr, Tcl_HashTable* BBHash, + BasicBlock* currBB, int fallsThrough, + int bcIndex, const char* jumpLabel); + +static int CheckStack(Tcl_Interp*, CompileEnv*, BasicBlock *, Tcl_Obj*); +static void FreeAssembleCodeInternalRep(Tcl_Obj *objPtr); +static ByteCode * CompileAssembleObj(Tcl_Interp *interp, Tcl_Obj *objPtr); +static int DefineLabel(Tcl_Interp* interp, CompileEnv* envPtr, + const char* label, Tcl_HashTable* labelHash); + +static const Tcl_ObjType assembleCodeType = { + "assemblecode", + FreeAssembleCodeInternalRep, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ +}; + +/* static int AdvanceIp(const unsigned char *pc); */ +static int StackCheckBasicBlock(StackCheckerState* , BasicBlock *, BasicBlock *, int); + +/* + * TIP #280: Remember the per-word line information of the current command. An + * index is used instead of a pointer as recursive compilation may reallocate, + * i.e. move, the array. This is also the reason to save the nuloc now, it may + * change during the course of the function. + * + * Macro to encapsulate the variable definition and setup. + */ + +#define DefineLineInformation \ + ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ + int eclIndex = mapPtr->nuloc - 1 + +#define SetLineInformation(word) \ + envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ + envPtr->clNext = mapPtr->loc[eclIndex].next[(word)] + +/* + * Flags bits used by PushVarName. + */ + +#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */ + +talInstDesc talInstructionTable[] = { + + /* PUSH must be first, see the code near the end of TclAssembleCode */ + + {"push", ASSEM_PUSH , (INST_PUSH1<<8 + | INST_PUSH4), 0 , 1}, + + {"add", ASSEM_1BYTE , INST_ADD , 2 , 1}, + {"append", ASSEM_LVT, (INST_APPEND_SCALAR1<<8 + | INST_APPEND_SCALAR4), + 1, 1}, + {"appendArray", + ASSEM_LVT, (INST_APPEND_ARRAY1<<8 + | INST_APPEND_ARRAY4), + 2, 1}, + {"appendArrayStk", + ASSEM_1BYTE, INST_APPEND_ARRAY_STK, + 3, 1}, + {"appendStk", + ASSEM_1BYTE, INST_APPEND_STK, + 2, 1}, + {"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,1}, + {"eval", ASSEM_EVAL, 0, 0, 1}, + {"evalStk", ASSEM_1BYTE, INST_EVAL_STK, 1, 1}, + {"exprStk", ASSEM_1BYTE, INST_EXPR_STK, 1, 1}, + {"exist", ASSEM_LVT4, INST_EXIST_SCALAR, + 0, 1}, + {"existArray", + ASSEM_LVT4, INST_EXIST_ARRAY, + 1, 1}, + {"existArrayStk", + ASSEM_1BYTE, INST_EXIST_ARRAY_STK, + 2, 1}, + {"existStk", + ASSEM_1BYTE, INST_EXIST_STK, 1, 1}, + {"bitand", ASSEM_1BYTE , INST_BITAND , 2 , 1}, + {"bitnot", ASSEM_1BYTE, INST_BITNOT, 2, 1}, + {"bitor", ASSEM_1BYTE , INST_BITOR , 2 , 1}, + {"bitxor", ASSEM_1BYTE , INST_BITXOR , 2 , 1}, + {"div", ASSEM_1BYTE, INST_DIV, 2, 1}, + {"dup", ASSEM_1BYTE , INST_DUP , 1 , 2}, + {"eq", ASSEM_1BYTE , INST_EQ , 2 , 1}, + {"expon", ASSEM_1BYTE, INST_EXPON, 2, 1}, + {"ge", ASSEM_1BYTE , INST_GE , 2 , 1}, + {"gt", ASSEM_1BYTE , INST_GT , 2 , 1}, + {"incr", ASSEM_LVT1, INST_INCR_SCALAR1, + 1, 1}, + {"incrArray", + ASSEM_LVT1, INST_INCR_ARRAY1, + 2, 1}, + {"incrArrayImm", + ASSEM_LVT1_SINT1, + INST_INCR_ARRAY1_IMM, + 1, 1}, + {"incrArrayStk", ASSEM_1BYTE, INST_INCR_ARRAY_STK, + 3, 1}, + {"incrArrayStkImm", + ASSEM_SINT1, INST_INCR_ARRAY_STK_IMM, + 2, 1}, + {"incrImm", + ASSEM_LVT1_SINT1, + INST_INCR_SCALAR1_IMM, + 0, 1}, + {"incrStk", ASSEM_1BYTE, INST_INCR_SCALAR_STK, + 2, 1}, + {"incrStkImm", + ASSEM_SINT1, INST_INCR_SCALAR_STK_IMM, + 1, 1}, + {"invokeStk", + ASSEM_INVOKE, (INST_INVOKE_STK1 << 8 + | INST_INVOKE_STK4), + INT_MIN,1}, + {"jump", ASSEM_JUMP, (INST_JUMP1 << 8 + | INST_JUMP4), 0, 0}, + {"jumpFalse", + ASSEM_JUMP, (INST_JUMP_FALSE1 << 8 + | INST_JUMP_FALSE4), + 1, 0}, + {"jumpTrue",ASSEM_JUMP, (INST_JUMP_TRUE1 << 8 + | INST_JUMP_TRUE4), + 1, 0}, + {"label", ASSEM_LABEL, 0, 0, 0}, + {"land", ASSEM_1BYTE , INST_LAND , 2 , 1}, + {"lappend", ASSEM_LVT, (INST_LAPPEND_SCALAR1<<8 + | INST_LAPPEND_SCALAR4), + 1, 1}, + {"lappendArray", + ASSEM_LVT, (INST_LAPPEND_ARRAY1<<8 + | INST_LAPPEND_ARRAY4), + 2, 1}, + {"lappendArrayStk", + ASSEM_1BYTE, INST_LAPPEND_ARRAY_STK, + 3, 1}, + {"lappendStk", + ASSEM_1BYTE, INST_LAPPEND_STK, + 2, 1}, + {"le", ASSEM_1BYTE , INST_LE , 2 , 1}, + {"listIndex", + ASSEM_1BYTE, INST_LIST_INDEX,2, 1}, + {"listLength", + ASSEM_1BYTE, INST_LIST_LENGTH, + 1, 1}, + {"load", ASSEM_LVT, (INST_LOAD_SCALAR1 << 8 + | INST_LOAD_SCALAR4), + 0, 1}, + {"loadArray", + ASSEM_LVT, (INST_LOAD_ARRAY1<<8 + | INST_LOAD_ARRAY4), + 1, 1}, + {"loadArrayStk", + ASSEM_1BYTE, INST_LOAD_ARRAY_STK, + 2, 1}, + {"loadStk", ASSEM_1BYTE, INST_LOAD_SCALAR_STK, + 1, 1}, + {"lor", ASSEM_1BYTE , INST_LOR , 2 , 1}, + {"lsetList", + ASSEM_1BYTE, INST_LSET_LIST, 3, 1}, + {"lshift", ASSEM_1BYTE , INST_LSHIFT , 2 , 1}, + {"lt", ASSEM_1BYTE , INST_LT , 2 , 1}, + {"mod", ASSEM_1BYTE, INST_MOD, 2, 1}, + {"mult", ASSEM_1BYTE , INST_MULT , 2 , 1}, + {"neq", ASSEM_1BYTE , INST_NEQ , 2 , 1}, + {"not", ASSEM_1BYTE, INST_LNOT, 2, 1}, + {"over", ASSEM_OVER, INST_OVER, INT_MIN, -1-1}, + {"pop", ASSEM_1BYTE , INST_POP , 1 , 0}, + {"reverse", ASSEM_REVERSE, INST_REVERSE, INT_MIN, -1-0}, + {"rshift", ASSEM_1BYTE , INST_RSHIFT , 2 , 1}, + {"store", ASSEM_LVT, (INST_STORE_SCALAR1<<8 + | INST_STORE_SCALAR4), + 1, 1}, + {"storeArray", + ASSEM_LVT, (INST_STORE_ARRAY1<<8 + | INST_STORE_ARRAY4), + 2, 1}, + {"storeArrayStk", + ASSEM_1BYTE, INST_STORE_ARRAY_STK, + 3, 1}, + {"storeStk", + ASSEM_1BYTE, INST_STORE_SCALAR_STK, + 2, 1}, + {"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1}, + {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1}, + {"strindex", + ASSEM_1BYTE, INST_STR_INDEX, 2, 1}, + {"strlen", ASSEM_1BYTE, INST_STR_LEN, 1, 1}, + {"strmatch", + ASSEM_BOOL, INST_STR_MATCH, 2, 1}, + {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, + {"sub", ASSEM_1BYTE , INST_SUB , 2 , 1}, + {"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1}, + {"unset", ASSEM_BOOL_LVT4, + INST_UNSET_SCALAR, + 0, 0}, + {"unsetArray", + ASSEM_BOOL_LVT4, + INST_UNSET_ARRAY, + 1, 0}, + {"unsetArrayStk", + ASSEM_BOOL, INST_UNSET_ARRAY_STK, + 2, 0}, + {"unsetStk", + ASSEM_BOOL, INST_UNSET_STK, 1, 0}, + {"uplus", ASSEM_1BYTE, INST_UPLUS, 1, 1}, + {NULL, 0, 0,0} +}; + +/* + *----------------------------------------------------------------------------- + * + * BBAdjustStackDepth -- + * + * When an opcode is emitted, adjusts the stack information in the + * basic block to reflect the number of operands produced and consumed. + * + * Results: + * None. + * + * Side effects: + * Updates minimum, maximum and final stack requirements in the + * basic block. + * + *----------------------------------------------------------------------------- + */ + +static void +BBAdjustStackDepth(BasicBlock* bbPtr, + /* Structure describing the basic block */ + int consumed, + /* Count of operands consumed by the + * operation */ + int produced) + /* Count of operands produced by the + * operation */ +{ + int depth = bbPtr->finalStackDepth; + depth -= consumed; + if (depth < bbPtr->minStackDepth) { + bbPtr->minStackDepth = depth; + } + depth += produced; + if (depth > bbPtr->maxStackDepth) { + bbPtr->maxStackDepth = depth; + } + bbPtr->finalStackDepth = depth; +#if 0 + fprintf(stderr, "update bb: consumed %d produced %d" + " min %d max %d final %d\n", + consumed, produced, bbPtr->minStackDepth, bbPtr->maxStackDepth, + bbPtr->finalStackDepth); + fflush(stderr); +#endif +} + +/* + *----------------------------------------------------------------------------- + * + * BBUpdateStackReqs -- + * + * Updates the stack requirements of a basic block, given the opcode + * being emitted and an operand count. + * + * Results: + * None. + * + * Side effects: + * Updates min, max and final stack requirements in the basic block. + * + * Notes: + * This function must not be called for instructions such as REVERSE + * and OVER that are variadic but do not consume all their operands. + * Instead, BBAdjustStackDepth should be called directly. + * + * count should be provided only for variadic operations. For + * operations with known arity, count should be 0. + * + *----------------------------------------------------------------------------- + */ + +static void +BBUpdateStackReqs(BasicBlock* bbPtr, + /* Structure describing the basic block */ + int tblind, /* Index in talInstructionTable of the + * operation being assembled */ + int count) /* Count of operands for variadic insts */ +{ + int consumed = talInstructionTable[tblind].operandsConsumed; + int produced = talInstructionTable[tblind].operandsProduced; + if (consumed == INT_MIN) { + /* The instruction is variadic; it consumes 'count' operands. */ + consumed = count; + } + if (produced < 0) { + /* The instruction leaves some of its operations on the stack, + * with net stack effect of '-1-produced' */ + produced = consumed - produced - 1; + } + BBAdjustStackDepth(bbPtr, consumed, produced); +} + +/* + *----------------------------------------------------------------------------- + * + * BBEmitOpcode, BBEmitInstInt1, BBEmitInstInt4 -- + * + * Emit the opcode part of an instruction, or the entirety of an + * instruction with a 1- or 4-byte operand, and adjust stack requirements. + * + * Results: + * None. + * + * Side effects: + * Stores instruction and operand in the operand stream, and + * adjusts the stack. + * + *----------------------------------------------------------------------------- + */ + +static void +BBEmitOpcode(CompileEnv* envPtr,/* Compilation environment */ + BasicBlock* bbPtr, /* Basic block to which the op belongs */ + int tblind, /* Table index in talInstructionTable of op */ + int count) /* Operand count for variadic ops */ +{ + int op = talInstructionTable[tblind].tclInstCode & 0xff; +#if 0 + fprintf(stderr, "Emit %s (%d)\n", tclInstructionTable[op].name, count); + fflush(stderr); +#endif + TclEmitInt1(op, envPtr); + envPtr->atCmdStart = ((op) == INST_START_CMD); + BBUpdateStackReqs(bbPtr, tblind, count); +} +static void +BBEmitInstInt1(CompileEnv* envPtr, + /* Compilation environment */ + BasicBlock* bbPtr, + /* basic block to which the op belongs */ + int tblind, /* Index in talInstructionTable of op */ + unsigned char opnd, + /* 1-byte operand */ + int count) /* Operand count for variadic ops */ +{ + BBEmitOpcode(envPtr, bbPtr, tblind, count); + TclEmitInt1(opnd, envPtr); +} +static void +BBEmitInstInt4(CompileEnv* envPtr, + /* Compilation environment */ + BasicBlock* bbPtr, + /* basic block to which the op belongs */ + int tblind, /* Index in talInstructionTable of op */ + int opnd, /* 4-byte operand */ + int count) /* Operand count for variadic ops */ +{ + BBEmitOpcode(envPtr, bbPtr, tblind, count); + TclEmitInt4(opnd, envPtr); +} + +/* + *----------------------------------------------------------------------------- + * + * BBEmitInst1or4 -- + * + * Emits a 1- or 4-byte operation according to the magnitude of the + * operand + * + *----------------------------------------------------------------------------- + */ + +static void +BBEmitInst1or4(CompileEnv* envPtr, + /* Compilation environment */ + BasicBlock* bbPtr, + /* Basic block under construction */ + int tblind, /* Index in talInstructionTable of op */ + int param, /* Variable-length parameter */ + int count) /* Arity if variadic */ +{ + + int op = talInstructionTable[tblind].tclInstCode; + if (param <= 0xff) { + op >>= 8; + } else { + op &= 0xff; + } +#if 0 + fprintf(stderr, "Emit %s (%d)\n", tclInstructionTable[op].name, count); + fflush(stderr); +#endif + TclEmitInt1(op, envPtr); + if (param <= 0xff) { + TclEmitInt1(param, envPtr); + } else { + TclEmitInt4(param, envPtr); + } + envPtr->atCmdStart = ((op) == INST_START_CMD); + BBUpdateStackReqs(bbPtr, tblind, count); +} + +int +Tcl_AssembleObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRAssembleObjCmd, dummy, objc, objv); +} + +int +TclNRAssembleObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *objPtr; + ByteCode *codePtr; + +#if 0 + int i; + fprintf(stderr, "TclNRAssembleObjCmd:"); + for (i=0; i < objc; ++i) { + fprintf(stderr, " {%s}", Tcl_GetString(objv[i])); + } + fprintf(stderr, "\n"); fflush(stderr); +#endif + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "bytecodeList"); + return TCL_ERROR; + } + + objPtr = objv[1]; + codePtr = CompileAssembleObj(interp, objPtr); + if (codePtr == NULL) { + return TCL_ERROR; + } + +#if 0 + fprintf(stderr, "bytecode: %p\n", codePtr); +#endif + Tcl_NRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), codePtr, + NULL, NULL); + + return TCL_OK; +} + +static ByteCode * +CompileAssembleObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr) +{ + Interp *iPtr = (Interp *) interp; + CompileEnv compEnv; /* Compilation environment structure allocated + * in frame. */ + register ByteCode *codePtr = NULL; + /* Tcl Internal type of bytecode. Initialized + * to avoid compiler warning. */ + int status; /* Status return from Tcl_AssembleCode */ + + /* + * Get the expression ByteCode from the object. If it exists, make sure it + * is valid in the current context. + */ + + if (objPtr->typePtr == &assembleCodeType) { + Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; + + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + if (((Interp *) *codePtr->interpHandle != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch) + || (codePtr->nsPtr != namespacePtr) + || (codePtr->nsEpoch != namespacePtr->resolverEpoch) + || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { + + FreeAssembleCodeInternalRep(objPtr); + } + } + if (objPtr->typePtr != &assembleCodeType) { + + int length; + + const char *string = TclGetStringFromObj(objPtr, &length); + TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0); +#if 0 + fprintf(stderr, "assembling: %s\n", string); fflush(stderr); +#endif + status = TclAssembleCode(interp, objPtr, &compEnv, TCL_EVAL_DIRECT); + if (status != TCL_OK) { +#if 0 + fprintf(stderr, "assembly failed: %s\n", + Tcl_GetString(Tcl_GetObjResult(interp))); + fflush(stderr); +#endif + /* FIXME - there's memory to clean up */ + return NULL; + } + + /* + * Successful compilation. If the expression yielded no instructions, + * push an zero object as the expression's result. + */ + + if (compEnv.codeNext == compEnv.codeStart) { + fprintf(stderr, "empty bytecode, why did this happen?\n"); + fflush(stderr); + TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1), + &compEnv); + } + + /* + * Add a "done" instruction as the last instruction and change the + * object into a ByteCode object. Ownership of the literal objects and + * aux data items is given to the ByteCode object. + */ + + TclEmitOpcode(INST_DONE, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); + objPtr->typePtr = &assembleCodeType; + TclFreeCompileEnv(&compEnv); + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + if (iPtr->varFramePtr->localCachePtr) { + codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; + codePtr->localCachePtr->refCount++; + } +#ifdef TCL_COMPILE_DEBUG + if (tclTraceCompile >= 2) { + TclPrintByteCodeObj(interp, objPtr); + fflush(stdout); + } +#endif /* TCL_COMPILE_DEBUG */ + } + return codePtr; +} + +/* + *----------------------------------------------------------------------------- + * + * TclCompileAssembleCmd -- + * + * Compilation procedure for the '::tcl::unsupported::assemble' command. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Puts the result of assembling the code into the bytecode stream + * in 'compileEnv'. + * + * This procedure makes sure that the command has a single arg, which is + * constant. If that condition is met, the procedure calls TclAssembleCode + * to produce bytecode for the given assembly code, and returns any error + * resulting from the assembly. + * + *----------------------------------------------------------------------------- + */ + +int TclCompileAssembleCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; /* Token in the input script */ + Tcl_Obj *bcList; /* List of assembly instructions to process */ + int status; /* Status return from assembling the code */ + + /* Make sure that the command has a single arg */ + + if (parsePtr->numWords != 2) { + return TCL_ERROR; + } + + /* Make sure that the arg is a simple word */ + + tokenPtr = TokenAfter(parsePtr->tokenPtr); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + return TCL_ERROR; + } + + /* Compile the code and return any error from the compilation */ + + bcList = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size); + Tcl_IncrRefCount(bcList); + status = TclAssembleCode(interp, bcList, envPtr, 0); + Tcl_DecrRefCount(bcList); + return status; + +} + +/* + *----------------------------------------------------------------------------- + * + * TclAssembleCode -- + * + * Take a list of instructions in a Tcl_Obj, and assemble them to + * Tcl bytecodes + * + * Results: + * Returns TCL_OK on success, TCL_ERROR on failure. + * If 'flags' includes TCL_EVAL_DIRECT, places an error message + * in the interpreter result. + * + * Side effects: + * Adds byte codes to the compile environment, and updates the + * environment's stack depth. + * + *----------------------------------------------------------------------------- + */ + +MODULE_SCOPE int +TclAssembleCode(Tcl_Interp *interp, + /* Tcl interpreter */ + Tcl_Obj * bcList, + /* List of assembly instructions */ + CompileEnv *envPtr, + /* Compilation environment that is to + * receive the generated bytecode */ + int flags) /* OR'ed combination of flags */ +{ + + int bcListLen = 0; /* Length of the assembly code list */ + Tcl_HashTable labelHash; /* Hashtable storing information about + * labels in the assembly code */ + Tcl_HashTable BBHash; /* Hashtable storing information about + * the basic blocks in the bytecode */ + + BasicBlock* curr_bb = NULL; /* Structure describing the current basic + * block */ + BasicBlock* head_bb = NULL; /* Structure describing the first basic + * block in the code */ + int ind; /* Index in the list of instructions */ + int result; /* Return value from this function */ + Tcl_Obj* bc; /* One assembly instruction from the list */ + int bcSize = 0; /* Length of the instruction sublist */ + Tcl_Obj ** bcArgs; /* Arguments to the instruction */ + char * instName; /* Name of the instruction */ + enum talInstType instType; /* Type of the current assembly instruction */ + unsigned char instCode; /* Opcode of the current assembly instruction */ + const char* operand1; /* First operand passed to the instruction */ + int operand1Len; /* Length of the first operand */ + int tblind = 0; /* Index in the instruction table of the + * current instruction */ + int isNew; /* Flag == 1 if a JUMP is the first + * occurrence of its associated label */ + Tcl_Obj* resultObj; /* Error message */ + int savedMaxStackDepth; /* Max stack depth saved around compilation + * calls */ + int savedCurrStackDepth; /* Current stack depth saved around + * compilation calls. */ + + int localVar, opnd = 0; + label *l; + Tcl_HashEntry * entry; + int litIndex; + + DefineLineInformation; /* TIP #280 */ /* eclIndex? */ + +#if 0 + fprintf(stderr, "Assembling: %s\n", Tcl_GetString(bcList)); + fflush(stderr); +#endif + + /* Test that the bytecode that we're given is a well formed list */ + + if (Tcl_ListObjLength(interp, bcList, &bcListLen) == TCL_ERROR) { + return TCL_ERROR; + } + + /* Initialize the symbol table and the table of basic blocks */ + + Tcl_InitHashTable(&labelHash, TCL_STRING_KEYS); + Tcl_InitHashTable(&BBHash, TCL_STRING_KEYS); + + /* Allocate a structure to describe the first basic block */ + + curr_bb = AllocBB(envPtr, 0); + head_bb = curr_bb; + + /* + * Index through the assembly directives and instructions, generating code. + */ + + for (ind = 0; ind < bcListLen; ind++) { + + /* Extract the instruction name from a list element */ + + result = TCL_OK; + if (Tcl_ListObjIndex(interp, bcList, ind, &bc) != TCL_OK + || Tcl_ListObjGetElements(interp, bc, &bcSize, &bcArgs) != TCL_OK) { + goto cleanup; + } + if (bcSize == 0) { + continue; + } + instName = Tcl_GetStringFromObj(bcArgs[0], NULL); +#if 0 + fprintf(stderr, "[%d] %s\n", + envPtr->codeNext - envPtr->codeStart, instName); + fflush(stderr); +#endif + + /* + * Extract the first operand, if there is one, and get its string + * representation + */ + + if (bcSize >= 2) { + operand1 = Tcl_GetStringFromObj(bcArgs[1], &operand1Len); + } else { + operand1 = NULL; + operand1Len = 0; + } + + /* Look up the instruction in the table of instructions */ + + if (Tcl_GetIndexFromObjStruct(interp, bcArgs[0], + &talInstructionTable[0].name, + sizeof(talInstDesc), "instruction", + TCL_EXACT, &tblind) != TCL_OK) { + goto cleanup; + } + + /* Vector on the type of instruction being processed */ + + instType = talInstructionTable[tblind].instType; + instCode = talInstructionTable[tblind].tclInstCode; + switch (instType) { + + case ASSEM_LABEL: + + if (bcSize != 2) { + Tcl_WrongNumArgs(interp, 1, bcArgs, "name"); + goto cleanup; + } + /* Add the (label_name, address) pair to the hash table */ + if (DefineLabel(interp, envPtr, operand1, &labelHash) != TCL_OK) { + goto cleanup; + } + + /* End the current basic block and start a new one */ + + curr_bb = StartBasicBlock(envPtr, &BBHash, curr_bb, 1, ind, NULL); + + /* Attach the label to the new basic block */ + + entry = Tcl_CreateHashEntry(&BBHash, operand1, &opnd); + Tcl_SetHashValue(entry, curr_bb); + + break; + + case ASSEM_1BYTE: + if (bcSize != 1) { + Tcl_WrongNumArgs(interp, 1, bcArgs, ""); + goto cleanup; + } + BBEmitOpcode(envPtr, curr_bb, tblind, 0); + break; + + case ASSEM_INVOKE: + if (bcSize != 2) { + Tcl_WrongNumArgs(interp, 1, bcArgs, "count"); + goto cleanup; + } + if (Tcl_GetIntFromObj(interp, bcArgs[1], &opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInst1or4(envPtr, curr_bb, tblind, opnd, opnd); + break; + + case ASSEM_JUMP: + if (bcSize != 2) { + Tcl_WrongNumArgs(interp, 1, bcArgs, "label"); + goto cleanup; + } + entry = Tcl_CreateHashEntry(&labelHash, operand1, &isNew); + if (isNew) { + l = (label *) ckalloc(sizeof(label)); + l -> isDefined = 0; + l -> offset = -1; + Tcl_SetHashValue(entry, l); + } else { + l = Tcl_GetHashValue(entry); + } + if (l -> isDefined) { + BBEmitInst1or4(envPtr, curr_bb, tblind, + l->offset + envPtr->codeStart + - envPtr->codeNext, 0); + } else { + int here = envPtr->codeNext - envPtr->codeStart; + BBEmitInstInt4(envPtr, curr_bb, tblind, + l->offset, 0); +#if 0 + fprintf(stderr, "forward ref to %s, prev at %d, link %d\n", + operand1, l->offset, here); +#endif + l->offset = here; + } + + /* Start a new basic block at the instruction following the jump */ + + curr_bb = + StartBasicBlock(envPtr, &BBHash, curr_bb, + talInstructionTable[tblind].operandsConsumed, + ind+1, operand1); + + break; + + case ASSEM_LVT: + if (bcSize != 2) { + Tcl_WrongNumArgs(interp, 1, bcArgs, "varname"); + goto cleanup; + } + if (CheckNamespaceQualifiers(interp, operand1)) { + goto cleanup; + } + localVar = TclFindCompiledLocal(operand1, operand1Len, 1, envPtr); + if (localVar == -1) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("cannot use this instruction" + " in non-proc context", -1)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL); + goto cleanup; + } + fprintf(stderr, "operand %s in slot %d\n", operand1, localVar); + BBEmitInst1or4(envPtr, curr_bb, tblind, localVar, 0); + break; + + case ASSEM_LVT1: + if (bcSize != 2) { + Tcl_WrongNumArgs(interp, 1, bcArgs, "varname"); + goto cleanup; + } + if (CheckNamespaceQualifiers(interp, operand1)) { + goto cleanup; + } + localVar = TclFindCompiledLocal(operand1, operand1Len, 1, envPtr); + if (localVar == -1) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("cannot use this instruction" + " in non-proc context", -1)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL); + goto cleanup; + } + if (CheckOneByte(interp, localVar)) { + goto cleanup; + } + BBEmitInstInt1(envPtr, curr_bb, tblind, localVar, 0); + break; + + case ASSEM_LVT4: + if (bcSize != 2) { + Tcl_WrongNumArgs(interp, 1, bcArgs, "varname"); + goto cleanup; + } + if (CheckNamespaceQualifiers(interp, operand1)) { + goto cleanup; + } + localVar = TclFindCompiledLocal(operand1, operand1Len, 1, envPtr); + if (localVar == -1) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("cannot use this instruction" + " in non-proc context", -1)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL); + goto cleanup; + } + BBEmitInstInt4(envPtr, curr_bb, tblind, localVar, 0); + break; + + case ASSEM_BOOL: + if (bcSize != 2) { + Tcl_WrongNumArgs(interp, 1, bcArgs, "boolean"); + goto cleanup; + } + if (Tcl_GetBooleanFromObj(interp, bcArgs[1], &opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt1(envPtr, curr_bb, tblind, opnd, 0); + break; + + case ASSEM_BOOL_LVT4: + if (bcSize != 3) { + Tcl_WrongNumArgs(interp, 1, bcArgs, "boolean varName"); + goto cleanup; + } + if (Tcl_GetBooleanFromObj(interp, bcArgs[1], &opnd) != TCL_OK) { + goto cleanup; + } + operand1 = Tcl_GetStringFromObj(bcArgs[2], &operand1Len); + if (CheckNamespaceQualifiers(interp, operand1)) { + goto cleanup; + } + localVar = TclFindCompiledLocal(operand1, operand1Len, 1, envPtr); + if (localVar == -1) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("cannot use this instruction" + " in non-proc context", -1)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL); + goto cleanup; + } + BBEmitInstInt1(envPtr, curr_bb, tblind, opnd, 0); + TclEmitInt4(localVar, envPtr); + break; + + case ASSEM_LVT1_SINT1: + if (bcSize != 3) { + Tcl_WrongNumArgs(interp, 1, bcArgs, "varName imm8"); + goto cleanup; + } + if (CheckNamespaceQualifiers(interp, operand1)) { + goto cleanup; + } + localVar = TclFindCompiledLocal(operand1, operand1Len, 1, envPtr); + if (localVar == -1) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("cannot use this instruction" + " in non-proc context", -1)); + Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL); + goto cleanup; + } + if (CheckOneByte(interp, localVar)) { + goto cleanup; + } + if (Tcl_GetIntFromObj(interp, bcArgs[2], &opnd) != TCL_OK) { + goto cleanup; + } + if (CheckSignedOneByte(interp, opnd)) { + goto cleanup; + } + BBEmitInstInt1(envPtr, curr_bb, tblind, localVar, 0); + TclEmitInt1(opnd, envPtr); + break; + + case ASSEM_OVER: + if (bcSize != 2) { + Tcl_WrongNumArgs(interp, 1, bcArgs, "count"); + goto cleanup; + } + if (Tcl_GetIntFromObj(interp, bcArgs[1], &opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt4(envPtr, curr_bb, tblind, opnd, opnd+1); + break; + + case ASSEM_PUSH: + if (bcSize != 2) { + Tcl_WrongNumArgs(interp, 1, bcArgs, "value"); + goto cleanup; + } + litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); + BBEmitInst1or4(envPtr, curr_bb, tblind, litIndex, 0); + break; + + case ASSEM_REVERSE: + if (bcSize != 2) { + Tcl_WrongNumArgs(interp, 1, bcArgs, "count"); + goto cleanup; + } + if (Tcl_GetIntFromObj(interp, bcArgs[1], &opnd) != TCL_OK) { + goto cleanup; + } + BBEmitInstInt4(envPtr, curr_bb, tblind, opnd, opnd); + break; + + case ASSEM_SINT1: + if (bcSize != 2) { + Tcl_WrongNumArgs(interp, 1, bcArgs, "imm8"); + goto cleanup; + } + if (Tcl_GetIntFromObj(interp, bcArgs[1], &opnd) != TCL_OK) { + goto cleanup; + } + if (CheckSignedOneByte(interp, opnd)) { + goto cleanup; + } + BBEmitInstInt1(envPtr, curr_bb, tblind, opnd, 0); + break; + + case ASSEM_CONCAT1: + if (bcSize != 2) { + Tcl_WrongNumArgs(interp, 1, bcArgs, "imm8"); + goto cleanup; + } + if (Tcl_GetIntFromObj(interp, bcArgs[1], &opnd) != TCL_OK) { + goto cleanup; + } + if (CheckOneByte(interp, opnd)) { + goto cleanup; + } + BBEmitInstInt1(envPtr, curr_bb, tblind, opnd, opnd); + break; + + case ASSEM_EVAL: + if (bcSize != 2) { + Tcl_WrongNumArgs(interp, 1, bcArgs, "script"); + goto cleanup; + } + fprintf(stderr, "compiling: %s\n", operand1); fflush(stderr); + savedMaxStackDepth = envPtr->maxStackDepth; + savedCurrStackDepth = envPtr->currStackDepth; + envPtr->maxStackDepth = 0; + envPtr->currStackDepth = 0; + TclCompileScript(interp, operand1, operand1Len, envPtr); + if (curr_bb->finalStackDepth + envPtr->maxStackDepth + > curr_bb->maxStackDepth) { + curr_bb->maxStackDepth = + curr_bb->finalStackDepth + envPtr->maxStackDepth; + } + curr_bb->finalStackDepth += envPtr->currStackDepth; + envPtr->maxStackDepth = savedMaxStackDepth; + envPtr->currStackDepth = savedCurrStackDepth; + fprintf(stderr, "compilation returns\n"); fflush(stderr); + break; + + default: + Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n", + instName); + } + + } + + /* Tie off the last basic block */ + + curr_bb->may_fall_thru = 0; + curr_bb->jumpTargetLabelHashEntry = NULL; + result = CheckStack(interp, envPtr, head_bb, bcList); + if (result != TCL_OK) { + goto cleanup; + } + if (curr_bb->visited) { + int depth = curr_bb->finalStackDepth + curr_bb->initialStackDepth; + if (depth == 0) { + /* Emit a 'push' of the empty literal */ + litIndex = TclRegisterNewLiteral(envPtr, "", 0); + /* Assumes that 'push' is at slot 0 in talInstructionTable */ + BBEmitInst1or4(envPtr, curr_bb, 0, litIndex, 0); + ++depth; + } + if (depth != 1) { + Tcl_Obj* depthObj = Tcl_NewIntObj(depth); + Tcl_IncrRefCount(depthObj); + resultObj = Tcl_NewStringObj("stack is unbalanced on exit " + "from the code (depth=", -1); + Tcl_AppendObjToObj(resultObj, depthObj); + Tcl_DecrRefCount(depthObj); + Tcl_AppendToObj(resultObj, ")", -1); + Tcl_SetObjResult(interp, resultObj); + goto cleanup; + } +#if 0 + fprintf(stderr, "before: stackDepth %d\n", envPtr->currStackDepth); +#endif + envPtr->currStackDepth += depth; +#if 0 + fprintf(stderr, "after: stackDepth %d\n", envPtr->currStackDepth); +#endif + fflush(stderr); + } + + Tcl_DeleteHashTable(&labelHash); // Actually, we need to free each label as well. + + return result; + + cleanup: + + /* FIXME: Need to make sure that allocated memory gets freed. */ + + if (ind >= 0 && ind < bcSize) { + Tcl_AddErrorInfo(interp, "\n processing "); + AddInstructionToErrorInfo(interp, bcList, ind); + } + + /* TODO: If ind != -1, add error info indicating where in the + * instruction stream things went wrong */ + + return TCL_ERROR; + +} + +/* + *----------------------------------------------------------------------------- + * + * CheckNamespaceQualifiers -- + * + * Verify that a variable name has no namespace qualifiers before + * attempting to install it in the LVT. + * + * Results: + * On success, returns TCL_OK. On failure, returns TCL_ERROR and + * stores an error message in the interpreter result. + * + *----------------------------------------------------------------------------- + */ + +static int +CheckNamespaceQualifiers(Tcl_Interp* interp, + /* Tcl interpreter for error reporting */ + const char* name) + /* Variable name to check */ +{ + Tcl_Obj* result; /* Error message */ + const char* p; + for (p = name; *p; p++) { + if ((*p == ':') && (p[1] == ':')) { + result = Tcl_NewStringObj("variable \"", -1); + Tcl_AppendToObj(result, name, -1); + Tcl_AppendToObj(result, "\" is not local", -1); + Tcl_SetObjResult(interp, result); + Tcl_SetErrorCode(interp, "TCL", "ASSEMBLE", "NONLOCAL", name, + NULL); + return TCL_ERROR; + } + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckOneByte -- + * + * Verify that a constant fits in a single byte in the instruction stream. + * + * Results: + * On success, returns TCL_OK. On failure, returns TCL_ERROR and + * stores an error message in the interpreter result. + * + * This code is here primarily to verify that instructions like INCR_SCALAR1 + * are possible on a given local variable. The fact that there is no + * INCR_SCALAR4 is puzzling. + * + *----------------------------------------------------------------------------- + */ + +static int +CheckOneByte(Tcl_Interp* interp, + /* Tcl interpreter for error reporting */ + int value) /* Value to check */ +{ + Tcl_Obj* result; /* Error message */ + if (value < 0 || value > 0xff) { + result = Tcl_NewStringObj("operand does not fit in 1 byte", -1); + Tcl_SetObjResult(interp, result); + Tcl_SetErrorCode(interp, "TCL", "ASSEMBLE", "1BYTE", NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * CheckSignedOneByte -- + * + * Verify that a constant fits in a single signed byte in the instruction + * stream. + * + * Results: + * On success, returns TCL_OK. On failure, returns TCL_ERROR and + * stores an error message in the interpreter result. + * + * This code is here primarily to verify that instructions like INCR_SCALAR1 + * are possible on a given local variable. The fact that there is no + * INCR_SCALAR4 is puzzling. + * + *----------------------------------------------------------------------------- + */ + +static int +CheckSignedOneByte(Tcl_Interp* interp, + /* Tcl interpreter for error reporting */ + int value) /* Value to check */ +{ + Tcl_Obj* result; /* Error message */ + if (value > 0x7f || value < -0x80) { + result = Tcl_NewStringObj("operand does not fit in 1 byte", -1); + Tcl_SetObjResult(interp, result); + Tcl_SetErrorCode(interp, "TCL", "ASSEMBLE", "1BYTE", NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * DefineLabel -- + * + * Defines a label appearing in the assembly sequence. + * + * Results: + * Returns a standard Tcl result. Returns TCL_OK and an empty result + * if the definition succeeds; returns TCL_ERROR and an appropriate + * message if a duplicate definition is found. + * + *----------------------------------------------------------------------------- + */ + +static int +DefineLabel(Tcl_Interp* interp, /* Tcl interpreter */ + CompileEnv* envPtr, /* Compilation environment */ + const char* labelName, /* Label being defined */ + Tcl_HashTable* labelHash) /* Symbol table */ +{ + Tcl_HashEntry* entry; /* Label's entry in the symbol table */ + int isNew; /* Flag == 1 iff the label was previously + * undefined */ + label* l; /* */ + Tcl_Obj* result; + + /* Look up the newly-defined label in the symbol table */ + + entry = Tcl_CreateHashEntry(labelHash, labelName, &isNew); + if (isNew) { + + /* This is the first appearance of the label in the code */ + + l = (label *)ckalloc(sizeof(label)); + l->isDefined = 1; + l->offset = envPtr->codeNext - envPtr->codeStart; + Tcl_SetHashValue(entry, l); + + } else { + + /* The label has appeared earlier. Make sure that it's not defined. */ + + l = (label *) Tcl_GetHashValue(entry); + if (l->isDefined) { + result = Tcl_NewStringObj("duplicate definition of label \"", -1); + Tcl_AppendToObj(result, labelName, -1); + Tcl_AppendToObj(result, "\"", -1); + Tcl_SetObjResult(interp, result); + return TCL_ERROR; + } else { + + /* + * Walk the linked list of previous references to the label + * and fix them up. + */ + + int jump = l->offset; + while (jump >= 0) { + int prevJump = TclGetInt4AtPtr(envPtr->codeStart + jump + 1); +#if 0 + fprintf(stderr, "fixup jump at %d to refer to %d\n", + jump, envPtr->codeNext - envPtr->codeStart); +#endif + TclStoreInt4AtPtr(envPtr->codeNext - envPtr->codeStart - jump, + envPtr->codeStart + jump + 1); + jump = prevJump; + } + l->offset = envPtr->codeNext - envPtr->codeStart; + l->isDefined = 1; + } + } + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * + * StartBasicBlock -- + * + * Starts a new basic block when a label or jump is encountered. + * + * Results: + * Returns a pointer to the BasicBlock structure of the new + * basic block. + * + *----------------------------------------------------------------------------- + */ + +static BasicBlock* +StartBasicBlock(CompileEnv* envPtr, + /* Compilation environment */ + Tcl_HashTable* BBHashPtr, + /* Hash table where basic blocks are recorded */ + BasicBlock* currBB, + /* Pointer to the BasicBlock structure + * of the block being closed. */ + int fallsThrough, + /* 1 if execution falls through into + * the following block, 0 otherwise */ + int bcIndex, /* Index of the current insn in the + * assembly stream */ + const char* jumpLabel) + /* Label of the location that the + * block jumps to, or NULL if the block + * does not jump */ +{ + int isNew; /* Unused return from Tcl_CreateHashEntry */ + BasicBlock* newBB; /* BasicBlock structure for the new basic block */ + + /* Coalesce zero-length blocks */ + + if (currBB->start == envPtr->codeNext) { + return currBB; + } + + /* Make the new basic block */ + + newBB = AllocBB(envPtr, bcIndex); + + /* Record the jump target if there is one. */ + + if (jumpLabel) { + currBB->jumpTargetLabelHashEntry = + Tcl_CreateHashEntry(BBHashPtr, jumpLabel, &isNew); + } else { + currBB->jumpTargetLabelHashEntry = NULL; + } + + /* Record the fallthrough if there is one. */ + + currBB->may_fall_thru = fallsThrough; + + /* Record the successor block */ + + currBB->successor1 = newBB; + return newBB; +} + +/* + *----------------------------------------------------------------------------- + * + * AllocBB -- + * + * Allocates a new basic block + * + * Results: + * Returns a pointer to the newly allocated block, which is initialized + * to contain no code and begin at the current instruction pointer. + * + *----------------------------------------------------------------------------- + */ + +static BasicBlock * +AllocBB(CompileEnv* envPtr, /* Compile environment containing the + * current instruction pointer */ + int bcIndex) /* Current index in the list of + * assembly instructions */ +{ + BasicBlock * bb = (BasicBlock *) ckalloc(sizeof(BasicBlock)); + + bb->start = envPtr->codeNext; + bb->bcIndex = bcIndex; + bb->initialStackDepth = 0; + bb->minStackDepth = 0; + bb->maxStackDepth = 0; + bb->finalStackDepth = 0; + + bb->visited = 0; + + bb->predecessor = NULL; + bb->jumpTargetLabelHashEntry = NULL; + bb->successor1 = NULL; + + return bb; +} + +static int +CheckStack(Tcl_Interp* interp, + CompileEnv* envPtr, + BasicBlock * head, + Tcl_Obj* bcList) { + StackCheckerState st; + st.interp = interp; + st.maxDepth = 0; + st.envPtr = envPtr; + st.bcList = bcList; + if(StackCheckBasicBlock(&st, head, NULL, 0) == TCL_ERROR) { + return TCL_ERROR; + } +#if 0 + fprintf(stderr, "Max stack anywhere is %d\n", st->maxDepth); +#endif + if (st.maxDepth + envPtr->currStackDepth > envPtr->maxStackDepth) { + envPtr->maxStackDepth = st.maxDepth + envPtr->currStackDepth; + } + return TCL_OK; +} + +static int +StackCheckBasicBlock(StackCheckerState *st, BasicBlock * blockPtr, BasicBlock * predecessor, int initialStackDepth) { +#if 0 + CompileEnv* envPtr = st->envPtr; + fprintf(stderr, "stack check basic block %p at depth %d\n", + blockPtr, initialStackDepth); + fprintf(stderr, " start %d may_fall_thru %d visited %d\n", + blockPtr->start - envPtr->codeStart, + blockPtr->may_fall_thru, blockPtr->visited); + fprintf(stderr, " predecessor %p successor1 %p\n", + blockPtr->predecessor, blockPtr->successor1); + fprintf(stderr, " stack: init %d min %d max %d final %d\n", + blockPtr->initialStackDepth, blockPtr->minStackDepth, + blockPtr->maxStackDepth, blockPtr->finalStackDepth); + fflush(stderr); +#endif + if (blockPtr->visited) { + if (blockPtr->initialStackDepth != initialStackDepth) { + Tcl_SetObjResult(st->interp, Tcl_NewStringObj("inconsistent stack depths on two execution paths", -1)); + /* Trace the offending BasicBlock */ + Tcl_AddErrorInfo(st->interp, "\n to "); + AddInstructionToErrorInfo(st->interp, st->bcList, + blockPtr->bcIndex); + /* TODO - add execution trace of both paths */ + return TCL_ERROR; + } else { + return TCL_OK; + } + } else { + + blockPtr->visited = 1; + blockPtr->predecessor = predecessor; + blockPtr->initialStackDepth = initialStackDepth; + if (initialStackDepth + blockPtr->minStackDepth < 0) { + Tcl_SetObjResult(st->interp, + Tcl_NewStringObj("stack underflow", -1)); + AddBasicBlockRangeToErrorInfo(st->interp, st->bcList, blockPtr); + return TCL_ERROR; + } + if (initialStackDepth + blockPtr->maxStackDepth > st->maxDepth) { + st->maxDepth = initialStackDepth + blockPtr->maxStackDepth; + } + } + int stackDepth = initialStackDepth + blockPtr->finalStackDepth; + int result = TCL_OK; +#if 0 + fprintf(stderr, "on exit from block, depth will be %d\n", stackDepth); + fflush(stderr); +#endif + if (blockPtr->may_fall_thru) { + result = StackCheckBasicBlock(st, blockPtr->successor1, blockPtr, stackDepth); + + } + /* FIXME Have we checked for undefined labels yet ? */ + if (result == TCL_OK && blockPtr->jumpTargetLabelHashEntry != NULL) { + BasicBlock * targetBlock = (BasicBlock *) Tcl_GetHashValue(blockPtr->jumpTargetLabelHashEntry); + result = StackCheckBasicBlock(st, targetBlock, blockPtr, stackDepth); + } + return result; + +} + +/* + *---------------------------------------------------------------------- + * + * FreeAssembleCodeInternalRep -- + * + * Part of the Tcl object type implementation for Tcl expression + * bytecode. Frees the storage allocated to hold the internal rep, unless + * ref counts indicate bytecode execution is still in progress. + * + * Results: + * None. + * + * Side effects: + * May free allocated memory. Leaves objPtr untyped. + * + *---------------------------------------------------------------------- + */ + +static void +FreeAssembleCodeInternalRep( + Tcl_Obj *objPtr) +{ + ByteCode *codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + objPtr->typePtr = NULL; + objPtr->internalRep.otherValuePtr = NULL; +} + +static void +AddBasicBlockRangeToErrorInfo(Tcl_Interp* interp, + Tcl_Obj* bcList, + BasicBlock* bbPtr) +{ + Tcl_AddErrorInfo(interp, "\n between "); + AddInstructionToErrorInfo(interp, bcList, bbPtr->bcIndex); + Tcl_AddErrorInfo(interp, "\n and "); + if (bbPtr->successor1 != NULL) { + AddInstructionToErrorInfo(interp, bcList, + bbPtr->successor1->bcIndex); + } else { + Tcl_AddErrorInfo(interp, "end of assembly code"); + } +} + +static void +AddInstructionToErrorInfo(Tcl_Interp* interp, + Tcl_Obj* bcList, + int bcIndex) +{ + Tcl_Obj* msgObj; + int msgLen; + const char* msgPtr; + + Tcl_AddErrorInfo(interp, "source instruction at list index "); + msgObj = Tcl_NewIntObj(bcIndex); + Tcl_IncrRefCount(msgObj); + msgPtr = Tcl_GetStringFromObj(msgObj, &msgLen); + Tcl_AddObjErrorInfo(interp, msgPtr, msgLen); + Tcl_DecrRefCount(msgObj); + Tcl_AddErrorInfo(interp, " (\""); + Tcl_ListObjIndex(NULL, bcList, bcIndex, &msgObj); + msgPtr = Tcl_GetStringFromObj(msgObj, &msgLen); + Tcl_AddObjErrorInfo(interp, msgPtr, msgLen); + Tcl_AddErrorInfo(interp, "\")"); +} + diff --git a/generic/tclAssembly.h b/generic/tclAssembly.h new file mode 100644 index 0000000..c788eed --- /dev/null +++ b/generic/tclAssembly.h @@ -0,0 +1,83 @@ +#ifndef _TCL_ASSEMBLY +#define _TCL_ASSEMBLY 1 + +#include "tclCompile.h" + +typedef struct StackCheckerState { + Tcl_Interp* interp; + CompileEnv* envPtr; + int maxDepth; + Tcl_Obj* bcList; +} StackCheckerState; + +typedef struct BasicBlock { + /* FIXME: start needs to be an offset from envPtr->codeStart */ + unsigned char * start; /* Instruction address of the start + * of the block */ + int bcIndex; /* Index in the input instruction + * list of the start of the block */ + int may_fall_thru; /* Flag == 1 if control passes from this + * block to its successor. */ + int visited; /* Flag==1 if this block has been visited + * in the stack checker*/ + struct BasicBlock* predecessor; + /* Predecessor of this block in the + * spanning tree */ + struct BasicBlock * successor1; + /* BasicBlock structure of the following + * block: NULL at the end of the bytecode + * sequence or if the block ends in an + * unconditional jump */ + Tcl_HashEntry * jumpTargetLabelHashEntry; + /* Jump target label if the jump target + * is unresolved */ + + int initialStackDepth; /* Absolute stack depth on entry */ + int minStackDepth; /* Low-water relative stack depth */ + int maxStackDepth; /* High-water relative stack depth */ + int finalStackDepth; /* Relative stack depth on exit */ + +} BasicBlock; + +typedef enum talInstType { + + ASSEM_1BYTE, /* The instructions that are directly mapped to tclInstructionTable in tclCompile.c*/ + ASSEM_BOOL, /* One Boolean operand */ + ASSEM_BOOL_LVT4,/* One Boolean, one 4-byte LVT ref. */ + ASSEM_CONCAT1, /* One 1-byte unsigned-integer operand count (CONCAT1) */ + ASSEM_EVAL, /* 'eval' - evaluate a constant script (by compiling it + * in line with the assembly code! I love Tcl!) */ + ASSEM_INVOKE, /* Command invocation, 1- or 4-byte unsigned operand + * count */ + ASSEM_JUMP, /* Jump instructions */ + ASSEM_LABEL, /* The assembly directive that defines a label */ + ASSEM_LVT, /* One operand that references a local variable */ + ASSEM_LVT1, /* One 1-byte operand that references a local variable */ + ASSEM_LVT1_SINT1, + /* One 1-byte operand that references a local variable, + * one signed-integer 1-byte operand */ + ASSEM_LVT4, /* One 4-byte operand that references a local variable */ + ASSEM_OVER, /* OVER: consumes n+1 operands and produces n+2 */ + ASSEM_PUSH, /* These instructions will be looked up from talInstructionTable */ + ASSEM_REVERSE, /* REVERSE: consumes n operands and produces n */ + ASSEM_SINT1, /* One 1-byte signed-integer operand (INCR_STK_IMM) */ +} talInstType; + +typedef struct talInstDesc { + const char *name; /* Name of instruction. */ + talInstType instType; /* The type of instruction */ + int tclInstCode; + int operandsConsumed; + int operandsProduced; + +} talInstDesc; + +typedef struct label { + int isDefined; + int offset; +} label; + +MODULE_SCOPE int TclAssembleCode(Tcl_Interp* interp, Tcl_Obj* code, + CompileEnv* compEnv, int flags); + +#endif diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 211771a..1413f66 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.465 2010/08/31 20:48:17 nijtmans Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.465.2.1 2010/09/21 19:32:26 kennykb Exp $ */ #include "tclInt.h" @@ -806,6 +806,13 @@ Tcl_CreateInterp(void) Tcl_DisassembleObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::tcl::unsupported::representation", Tcl_RepresentationCmd, NULL, NULL); + + /* Adding the bytecode assembler command */ + cmdPtr = (Command*) + Tcl_NRCreateCommand(interp, "::tcl::unsupported::assemble", + Tcl_AssembleObjCmd, TclNRAssembleObjCmd, + NULL, NULL); + cmdPtr->compileProc = &TclCompileAssembleCmd; Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldTo", NULL, TclNRYieldToObjCmd, NULL, NULL); diff --git a/generic/tclInt.h b/generic/tclInt.h index 1fb8869..a2fb49f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.482 2010/08/30 14:02:10 msofer Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.482.2.1 2010/09/21 19:32:26 kennykb Exp $ */ #ifndef _TCLINT @@ -3163,6 +3163,15 @@ MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); + +/* Assemble command function */ +MODULE_SCOPE int Tcl_AssembleObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +MODULE_SCOPE int TclNRAssembleObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); + MODULE_SCOPE int Tcl_EncodingObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3656,6 +3665,10 @@ MODULE_SCOPE int TclStreqOpCmd(ClientData clientData, MODULE_SCOPE int TclCompileStreqOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); + +MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); /* * Functions defined in generic/tclVar.c and currenttly exported only for use diff --git a/tests/assemble.test b/tests/assemble.test new file mode 100644 index 0000000..d0cbdaa --- /dev/null +++ b/tests/assemble.test @@ -0,0 +1,516 @@ +# Commands covered: assemble + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2.2 + namespace import -force ::tcltest::* +} +set assemble tcl::unsupported::assemble + +test assemble-1.1 {wrong # args} { + -body { $assemble 1 2 } + -result {wrong # args: should be "tcl::unsupported::assemble bytecodeList"} + -returnCodes error +} + +test assemble-1.2 {wrong arg formatting} { + -body { $assemble 1 } + -match glob + -returnCodes error + -result {bad instruction "1"*} +} + +test assemble-1.3 {empty body} { + -body { $assemble "" } + -result {} +} + +test assemble-1.4 {empty body} { + -body { + proc x y { + tcl::unsupported::assemble "" + } + x 1} + -result {} +} + +test assemble-1.5 {Testing push and add} { + -body { tcl::unsupported::assemble {{push 2} {push 2} {add}} } + -result {4} +} + +test assemble-1.6 {Testing push, dup, add} { + -body { tcl::unsupported::assemble {{push 2} {dup} {add}} } + -result {4} +} + +test assemble-1.6a {wrong # args} { + -body { + catch { + tcl::unsupported::assemble {{push 2 2} {dup} {add}} + } + set ::errorInfo + } + -match glob + -result {wrong # args: should be "push value" + processing source instruction at list index 0 ("push 2 2")*} +} + +test assemble-1.7 { Testing push, dup, mul, push, dup, mult, push, expon sequence } { + -body { tcl::unsupported::assemble {{push 3} dup mult {push 4} dup mult expon}} + -result {1853020188851841} +} + +test assemble-1.8 { Testing push, dup, mul, push, dup, mult, push, expon, pop sequence with unbalanced stack } {*}{ + -body { + list \ + [catch { + tcl::unsupported::assemble { + {push 3} + dup + mult + {push 4} + dup + mult + pop + expon} + } result] $result $::errorInfo + } + -result {1 {stack underflow} {stack underflow + between source instruction at list index 0 ("push 3") + and end of assembly code*}} + -match glob + -returnCodes ok +} +test assemble-1.8a {unbalanced stack} {*}{ + -body { + list \ + [catch { + tcl::unsupported::assemble { + {label a} + {pop} + {label b} + {pop} + } + } result] $result $::errorInfo + } + -result {1 {stack underflow} {stack underflow + between source instruction at list index 0 ("label a") + and source instruction at list index 2 ("label b")*}} + -match glob + -returnCodes ok +} + +# Tests for load and store + +test assemble-1.9 { Testing load within a proc } { + -body { proc x y { tcl::unsupported::assemble {{load y} dup mult }} + x 10 + } + -result {100} +} + +test assemble-1.10 { Testing store and load, saving the string "aString" to a variable and then + loading it from variable } { + -body { + proc x arg { + tcl::unsupported::assemble { + {push aString} {store arg} {pop} {load arg}} + } + x "not_aString" + } + -result {aString} + } + +test assemble-1.11 { Testing storeArray and loadArray } { + -body { set anArray(1,2) "not_aString" + proc x arg { + upvar $arg anArray + tcl::unsupported::assemble { + {push 1,2} + {push aString} + {storeArray anArray} + pop + {push 1,2} + {loadArray anArray} + } + } + x anArray + } + -cleanup {unset anArray} + -result {aString} +} + +test assemble-1.12 { Testing loadStk with a variable } { + -body { set vara 10 + tcl::unsupported::assemble {{push vara} loadStk dup mult {push 4} dup mult add}} + -cleanup {unset vara} + -result {116} +} + +test assemble-1.13 { Testing loadStk with an array variable } { + -body { set vararr(1,2) 10 + tcl::unsupported::assemble {{push vararr(1,2)} loadStk dup mult {push 4} dup mult add}} + -cleanup {unset vararr} + -result {116} +} + + +test assemble-1.14 { Testing loadStk and storeStk } { + -body { + set aVar 5 + tcl::unsupported::assemble { + {push aVar} + {push aString} + {storeStk} + pop + {push aVar} + loadStk + } + } + -cleanup {unset aVar} + -result {aString} +} + +test assemble-1.15 { Testing loadArrayStk and storeArrayStk } { + -body { + set aVar(1,2) 5 + tcl::unsupported::assemble { + {push aVar} + {push 1,2} + {push aString} + {storeArrayStk} + pop + {push aVar} + {push 1,2} + loadArrayStk + } + } + -cleanup {unset aVar} + -result {aString} +} + +# Tests for incr instructions + +test assemble-1.16 { Testing incr } { + -body { proc x arg { set i 5 + tcl::unsupported::assemble {{push 5} {incr i}} + } + x 1 + } + -result {10} +} + +test assemble-1.17 { Testing incrImm } { + -body { proc x arg { set i 5 + tcl::unsupported::assemble {{incrImm i 5}} + } + x 1 + } + -result {10} +} + +test assemble-1.18 { Testing incrStk } { + -body { proc x arg { set i 5 + tcl::unsupported::assemble {{push i} {push 5} {incrStk}} + } + x 1 + } + -result {10} +} + +test assemble-1.19 { Testing incrStkImm } { + -body { proc x arg { set i 5 + tcl::unsupported::assemble {{push i} {incrStkImm 5}} + } + x 1 + } + -result {10} +} + +test assemble-1.20 { Testing incrStkImm } { + -body { proc x arg { set i 5 + tcl::unsupported::assemble {{push i} {incrStkImm 5}} + } + x 1 + } + -result {10} +} + +test assemble-1.21 { Testing incrArray } { + -body { proc x arg { set i(1,2) 5 + tcl::unsupported::assemble {{push 1,2} {push 5} {incrArray i}} + } + x 1 + } + -result {10} +} + +test assemble-1.22 { Testing incrArrayImm } { + -body { proc x arg { set i(1,2) 5 + tcl::unsupported::assemble {{push 1,2} {incrArrayImm i 5}} + } + x 1 + } + -result {10} +} + +test assemble-1.23 { Testing incrArrayStk } { + -body { proc x arg { set i(1,2) 5 + tcl::unsupported::assemble {{push i} {push 1,2} {push 5} {incrArrayStk}} + } + x 1 + } + -result {10} +} + +test assemble-1.24 { Testing incrArrayStkImm } { + -body { proc x arg { set i(1,2) 5 + tcl::unsupported::assemble {{push i} {push 1,2} {incrArrayStkImm 5}} + } + x 1 + } + -result {10} +} + +# Tests for STRs -NOT HERE YET +# Tests for LIST BYTECODES -NOT HERE YET + +# Tests for label and jump {push NotEqual} + +test assemble-1.25 { Testing label and jumpTrue } { + -body { + proc x {arg1 arg2} { tcl::unsupported::assemble {{label a} {load arg2} + {push 2} {mult} {store arg2} pop {load arg1} {push 1} {sub} {store arg1} + {push 0} {neq} {jumpTrue a} {load arg2}}} + x 4 2 + } + -result {32} +} + +test assemble-1.26 { Testing label and jumpFalse } { + -body { + proc x {arg1 arg2} { tcl::unsupported::assemble {{label a} {load arg2} + {push 2} {mult} {store arg2} pop {load arg1} {push 1} {sub} {store arg1} + {push 0} {eq} {jumpFalse a} {load arg2}}} + x 4 2 + } + -result {32} +} + +test assemble-1.27 { Testing trampoline undefined label and jump } { + -body { + proc x {arg1 arg2 arg3} { tcl::unsupported::assemble {{jump a} {push aString} + {store arg1} pop {label a} {jump b} {push aString} {store arg2} {label b} {jump c} + {push aString} {store arg3} {label c} {load arg1} }} + x 1 2 3 + } + -result {1} +} + +test assemble-1.28 { Testing trampoline undefined label and jump } { + -body { + proc x {arg1 arg2 arg3} { tcl::unsupported::assemble {{jump a} {push aString} + {store arg1} pop {label a} {jump b} {push aString} {store arg2} {label b} {jump c} + {push aString} {store arg3} {label c} {load arg2} }} + x 1 2 3 + } + -result {2} +} + +test assemble-1.29 { Testing trampoline undefined label and jump } { + -body { + proc x {arg1 arg2 arg3} { tcl::unsupported::assemble {{jump a} {push aString} + {store arg1} pop {label a} {jump b} {push aString} {store arg2} {label b} {jump c} + {push aString} {store arg3} {label c} {load arg3} }} + x 1 2 3 + } + -result {3} +} + +test assemble-1.30 {Inconsistent stack usage} {*}{ + -body { + proc x {y} { + tcl::unsupported::assemble { + {load y} + {jumpFalse else} + {push 0} + {jump then} + {label else} + {push 1} + {push 2} + {label then} + pop + } + } + catch {x 1} + set errorInfo + } + -match glob + -result {inconsistent stack depths on two execution paths + to source instruction at list index 7 ("label then")*} +} + +test assemble-1.31 {unset, exists, lappend - smoke test} { + -body { + proc x {y} { + tcl::unsupported::assemble { + {exist result} + {store result} + {pop} + + {exist result} + {lappend result} + {pop} + + {push result} + {push y} + {existStk} + {lappendStk} + {pop} + + {push y} + {unsetStk true} + {exist y} + {lappend result} + {pop} + + {push {}} + {store foo} + {pop} + {exist foo} + {lappend result} + {pop} + + {unset true foo} + {exist foo} + {lappend result} + {pop} + + {push a} + {existArray z} + {lappend result} + {pop} + + {push a} + {push b} + {lappendArray z} + {lappend result} + {pop} + + {push z} + {push a} + {existArrayStk} + {lappend result} + {pop} + + {push z} + {push a} + {push c} + {lappendArrayStk} + {lappend result} + + } + } + x 1 + } + -result {0 1 1 0 1 0 0 b 1 {b c}} +} + +test assemble-2.1 {concat} { + -body { + ::tcl::unsupported::assemble { + {push a} + {push b} + {push c} + {concat 3} + } + } + -result abc +} + +test assemble-3.1 {expr} { + -body { + ::tcl::unsupported::assemble { + {push {1+2+3+4+5}} + {exprStk} + } + } + -result 15 +} +test assemble-4.1 {eval} { + -body { + ::tcl::unsupported::assemble { + {push {join [list [expr {1+2+3+4+5}] a] {}}} + {evalStk} + } + } + -result 15a +} +set ::tcl_traceCompile 2 +test assemble-4.2 {eval} { + -body { + proc x {} { + ::tcl::unsupported::assemble { + {push 3} + {store n} + pop + {eval {expr {3*$n + 1}}} + } + } + x + } + -result 10 +} +set ::tcl_traceCompile 0 + +test assemble-30.1 {Ulam's 3n+1 problem, TAL implementation} { + -body { + regsub -all {\#[^\n]*} { + {load n} # max + {dup} # max n + {jump start} # max n + + {label loop} # max n + {over 1} # max n max + {over 1} # max n max n + {ge} # man n max>=n + {jumpTrue skip} # max n + + {reverse 2} # n max + {pop} # n + {dup} # n n + + {label skip} # max n + {dup} # max n n + {push 2} # max n n 2 + {mod} # max n n%2 + {jumpTrue odd} # max n + + {push 2} # max n 2 + {div} # max n/2 -> max n + {jump start} # max n + + {label odd} # max n + {push 3} # max n 3 + {mult} # max 3*n + {push 1} # max 3*n 1 + {add} # max 3*n+1 + + {label start} # max n + {dup} # max n n + {push 1} # max n n 1 + {neq} # max n n>1 + {jumpTrue loop} # max n + + {pop} # max + + } {} code + proc ulam n [list tcl::unsupported::assemble $code] + set result {} + for {set i 1} {$i < 30} {incr i} { + lappend result [ulam $i] + } + set result + } + -result {1 2 16 4 16 16 52 8 52 16 52 16 40 52 160 16 52 52 88 20 64 52 160 24 88 40 9232 52 88} +} \ No newline at end of file diff --git a/tests/assemble1.bench b/tests/assemble1.bench new file mode 100644 index 0000000..4f4dbce --- /dev/null +++ b/tests/assemble1.bench @@ -0,0 +1,60 @@ +proc ulam1 {n} { + set max $n + while {$n != 1} { + if {$n > $max} { + set max $n + } + if {$n % 2} { + set n [expr {3 * $n + 1}] + } else { + set n [expr {$n / 2}] + } + } + return $max +} +set i 0 +puts [time {ulam1 [incr i]} 10000] + +regsub -all {\#[^\n]*} { + {load n} # max + {dup} # max n + {jump start} # max n + + {label loop} # max n + {over 1} # max n max + {over 1} # max n max n + {ge} # man n max>=n + {jumpTrue skip} # max n + + {reverse 2} # n max + {pop} # n + {dup} # n n + + {label skip} # max n + {dup} # max n n + {push 2} # max n n 2 + {mod} # max n n%2 + {jumpTrue odd} # max n + + {push 2} # max n 2 + {div} # max n/2 -> max n + {jump start} # max n + + {label odd} # max n + {push 3} # max n 3 + {mult} # max 3*n + {push 1} # max 3*n 1 + {add} # max 3*n+1 + + {label start} # max n + {dup} # max n n + {push 1} # max n n 1 + {neq} # max n n>1 + {jumpTrue loop} # max n + + {pop} # max + +} {} code +proc ulam2 n [list tcl::unsupported::assemble $code] +set i 0 +puts [time {ulam2 [incr i]} 10000] diff --git a/unix/Makefile.in b/unix/Makefile.in index 4006bf0..3175283 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -4,7 +4,7 @@ # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.306 2010/09/16 17:49:41 hobbs Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.306.2.1 2010/09/21 19:32:26 kennykb Exp $ VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ @@ -308,7 +308,8 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclStrToD.o tclThread.o \ tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \ tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \ - tclTomMathInterface.o + tclTomMathInterface.o \ + tclAssembly.o OO_OBJS = tclOO.o tclOOBasic.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o \ tclOOMethod.o tclOOStubInit.o @@ -362,6 +363,7 @@ TCL_DECLS = \ GENERIC_HDRS = \ $(GENERIC_DIR)/tcl.h \ + $(GENERIC_DIR)/tclAssembly.h \ $(GENERIC_DIR)/tclDecls.h \ $(GENERIC_DIR)/tclInt.h \ $(GENERIC_DIR)/tclIntDecls.h \ @@ -383,6 +385,7 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/regfree.c \ $(GENERIC_DIR)/regerror.c \ $(GENERIC_DIR)/tclAlloc.c \ + $(GENERIC_DIR)/tclAssembly.c \ $(GENERIC_DIR)/tclAsync.c \ $(GENERIC_DIR)/tclBasic.c \ $(GENERIC_DIR)/tclBinary.c \ @@ -451,6 +454,7 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclTrace.c \ $(GENERIC_DIR)/tclUtil.c \ $(GENERIC_DIR)/tclVar.c \ + $(GENERIC_DIR)/tclAssembly.c \ $(GENERIC_DIR)/tclZlib.c OO_SRCS = \ @@ -1002,6 +1006,9 @@ tclAppInit.o: $(UNIX_DIR)/tclAppInit.c tclAlloc.o: $(GENERIC_DIR)/tclAlloc.c $(CC) -c $(CC_SWITCHES) -DUSE_TCLALLOC=0 $(GENERIC_DIR)/tclAlloc.c +tclAssembly.o: $(GENERIC_DIR)/tclAssembly.c $(COMPILEHDR) + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAssembly.c + tclAsync.o: $(GENERIC_DIR)/tclAsync.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAsync.c diff --git a/win/Makefile.in b/win/Makefile.in index 0c0c0bb..ed7377a 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -4,7 +4,7 @@ # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.184 2010/08/30 09:19:38 nijtmans Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.184.2.1 2010/09/21 19:32:26 kennykb Exp $ VERSION = @TCL_VERSION@ @@ -212,6 +212,7 @@ GENERIC_OBJS = \ regfree.$(OBJEXT) \ regerror.$(OBJEXT) \ tclAlloc.$(OBJEXT) \ + tclAssembly.$(OBJEXT) \ tclAsync.$(OBJEXT) \ tclBasic.$(OBJEXT) \ tclBinary.$(OBJEXT) \ diff --git a/win/makefile.vc b/win/makefile.vc index 8e0ea11..9e36522 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -13,7 +13,7 @@ # Copyright (c) 2003-2008 Pat Thoyts. # #------------------------------------------------------------------------------ -# RCS: @(#) $Id: makefile.vc,v 1.214 2010/09/09 14:30:20 nijtmans Exp $ +# RCS: @(#) $Id: makefile.vc,v 1.214.2.1 2010/09/21 19:32:26 kennykb Exp $ #------------------------------------------------------------------------------ # Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR) @@ -250,6 +250,7 @@ COREOBJS = \ $(TMP_DIR)\regexec.obj \ $(TMP_DIR)\regfree.obj \ $(TMP_DIR)\tclAlloc.obj \ + $(TMP_DIR)\tclAssembly.obj \ $(TMP_DIR)\tclAsync.obj \ $(TMP_DIR)\tclBasic.obj \ $(TMP_DIR)\tclBinary.obj \ -- cgit v0.12