summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog16
-rw-r--r--generic/tclAssembly.c1537
-rw-r--r--generic/tclAssembly.h83
-rw-r--r--generic/tclBasic.c9
-rw-r--r--generic/tclInt.h15
-rw-r--r--tests/assemble.test516
-rw-r--r--tests/assemble1.bench60
-rw-r--r--unix/Makefile.in11
-rw-r--r--win/Makefile.in3
-rw-r--r--win/makefile.vc3
10 files changed, 2247 insertions, 6 deletions
diff --git a/ChangeLog b/ChangeLog
index 700f8f1..1d734fe 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,19 @@
+2010-09-21 Kevin B. Kenny <kennykb@acm.org>
+
+ [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 <nijtmans@users.sf.net>
* 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 \
generated by cgit v0.12 at 2024-11-18 19:19:34 (GMT)