added new files generic/tclNRE.h and tests/NRE.test

2 files changed, 575 insertions, 0 deletions

diff --git a/generic/tclNRE.h b/generic/tclNRE.h
new file mode 100644
index 0000000..d892f61
--- /dev/null
+++ b/generic/tclNRE.h
@@ -0,0 +1,267 @@
+/*
+ * tclNRE.h --
+ *
+ *	This file contains declarations for the infrastructure for
+ *	non-recursive commands. Contents may or may not migrate to tcl.h,
+ *	tcl.decls, tclInt.h and/or tclInt.decls
+ *
+ * Copyright (c) 2008 by Miguel Sofer
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * // FIXME: RCS numbering?
+ * RCS: @(#) $Id: tclNRE.h,v 1.1 2008/07/13 09:04:54 msofer Exp $
+ */
+
+
+#ifndef _TCLNONREC
+#define _TCLNONREC
+
+/*****************************************************************************
+ * Stuff during devel
+ *****************************************************************************/
+
+#define USE_SMALL_ALLOC     1 /* perf is important for some of these things! */
+#define USE_STACK_ALLOC     1 /* good mainly for debugging, crashes at
+			       * smallest timing error */
+#define ENABLE_ASSERTS      1
+
+/*
+ *   IMPLEMENTED IN THIS VERSION - flags for partial enabling of the different
+ *   parts, useful for debugging. May not work - meant to be used at "all ones"
+ */
+
+#define USE_NR_PROC         1 /* are procs defined as NR functions or not?
+			       * Used for testing that the old interfaces
+			       * still work, as they are used by TclOO and
+			       * iTcl */
+#define USE_NR_TEBC         1 /* does TEBC know about his special powers?
+			       * with 1 TEBC remains on stack, TEOV gets
+			       * evicted. */
+#define USE_NR_ALIAS        1 /* First examples: my job */
+
+#define USE_NR_IMPORTS      1 /* First examples: my job */
+
+#define USE_NR_TAILCALLS    1 /* Incomplete implementation as
+			       * tcl::unsupported::tailcall; best semantics
+			       * are yet not 100% clear to me. */
+
+#define USE_NR_NS_ENSEMBLE  1 /* snit!! */
+
+/* Here to remind me of what's still missing: none of these do anything today */
+
+#define USE_NR_EVAL         0 /* Tcl_EvalObj should be easy; the others may
+			       * require some adapting of the parser. dgp? */
+#define USE_NR_UPLEVEL      0 /* piece of cake, I think */
+#define USE_NR_VAR_TRACES   0 /* require major redesign, I fear. About time
+			       * for it too! */
+
+#define USE_NR_CONTINUATIONS 0
+
+#define MAKE_3X_FASTER       0
+#define RULE_THE_WORLD       0
+
+#define USE_NR_CMD_TRACES  /* NEVER?? Maybe ... enter traces on the way in,
+			    * leave traces done in the callback? So a trace
+			    * just needs to replace the procPtr and
+			    * clientData, and TEOV needn't know about the
+			    * whole s**t! Mmhhh */
+
+/*****************************************************************************
+ * Stuff for the public api: gone to the stubs table!
+ *
+ * Question: should we allow more callback requests during the callback
+ * itself? Easy enough to either handle or block, nothing done yet. We could
+ * also "lock" the Tcl stack during postProc, but it doesn't sound
+ * reasonable. I think.
+ *****************************************************************************/
+
+/*****************************************************************************
+ * Private api fo NRE
+ *****************************************************************************/
+
+/*
+ * Main data struct for representing NR commands (generated at runtime). 
+ */
+
+struct ByteCode;
+
+/* Fill up a SmallAlloc: 4 free ptrs for the user */
+typedef struct TEOV_callback {
+    TclNR_PostProc *procPtr;
+    ClientData data0;
+    ClientData data1;
+    ClientData data2;
+    ClientData data3;
+    struct TEOV_callback *nextPtr;
+} TEOV_callback;
+    
+
+/* Try to keep within SmallAlloc sizes! */
+typedef struct TEOV_record {
+    int type;
+    Command *cmdPtr;
+    TEOV_callback *callbackPtr;
+    struct TEOV_record *nextPtr;
+    union {
+	struct ByteCode *codePtr;
+	struct {
+	    Tcl_Obj *objPtr;
+	    int flags;
+	} obj;
+	struct {
+	    Tcl_ObjCmdProc *objProc;
+	    ClientData clientData;
+	} objProc;
+	struct {
+	    int objc;
+	    Tcl_Obj *const *objv;
+	} objv;
+    } data;
+#if !USE_SMALL_ALLOC
+    /* Extra checks: can disappear later */
+    Tcl_Obj **tosPtr;
+#endif
+} TEOV_record;
+
+/*
+ * The types for records; we save the first bit to indicate that it stores an
+ * obj, to indicate the necessary refCount management. That is, odd numbers
+ * only for obj-carrying types
+ */
+
+#define TCL_NR_NO_TYPE             0  /* for internal (cleanup) use only */
+#define TCL_NR_BC_TYPE             2  /* procs, lambdas, TclOO+Itcl sometime ... */ 
+#define TCL_NR_OBJPROC_TYPE        4  /* ns-imports (cmdd redirect) */
+#define TCL_NR_TAILCALL_TYPE       6  
+#define TCL_NR_TEBC_SWAPENV_TYPE   8  /* continuations, micro-threads !? */
+
+#define TCL_NR_CMD_TYPE           1  /* i-alias, ns-ens use this */
+#define TCL_NR_SCRIPT_TYPE         3  /* ns-eval, uplevel use this */
+
+#define TCL_NR_HAS_OBJ(TYPE) ((TYPE) & 1)
+
+#define TOP_RECORD(iPtr) (((Interp *)(iPtr))->execEnvPtr->recordPtr)
+
+#define GET_TOSPTR(iPtr)			\
+    (((Interp *)iPtr)->execEnvPtr->execStackPtr->tosPtr)
+
+#if !USE_SMALL_ALLOC
+#define STORE_EXTRA(iPtr, recordPtr)		\
+    recordPtr->tosPtr = GET_TOSPTR(iPtr)
+#else
+#define STORE_EXTRA(iPtr, recordPtr)
+#endif
+
+/* A SINGLE record being pushed is what is detected as an NRE request by TEOV */ 
+
+#define PUSH_RECORD(iPtr, recordPtr)				\
+    TCLNR_ALLOC(interp, recordPtr);	\
+    recordPtr->nextPtr = TOP_RECORD(iPtr);			\
+    STORE_EXTRA(iPtr, recordPtr);				\
+    TOP_RECORD(iPtr) = recordPtr;				\
+    recordPtr->type = TCL_NR_NO_TYPE;                             \
+    recordPtr->cmdPtr = NULL;            			\
+    recordPtr->callbackPtr = NULL
+
+#define TEBC_CALL(iPtr)				\
+    (((Interp *)iPtr)->execEnvPtr->tebcCall)
+
+#define TEBC_DATA(iPtr)				\
+    (((Interp *)iPtr)->execEnvPtr->tebcData)
+
+#define TEBC_DO_EXEC             1  /* MUST NOT be 0 */
+#define TEBC_DO_TAILCALL         2
+
+/*
+ * These are only used by TEOV; here for ease of ref. They should move to
+ * tclBasic.c later on.
+ */
+
+#define COMPLETE_RECORD(recordPtr)			\
+    /* accesses variables by name, careful */		\
+    recordPtr->cmdPtr = cmdPtr;				\
+
+#if !USE_SMALL_ALLOC
+#define CHECK_EXTRA(iPtr, recordPtr)		\
+    (recordPtr->tosPtr == GET_TOSPTR(iPtr))
+#else
+#define CHECK_EXTRA(iPtr, recordPtr) 1
+#endif
+
+#define POP_RECORD(iPtr, recordPtr)		\
+    {						\
+	recordPtr = TOP_RECORD(iPtr);		\
+	TOP_RECORD(iPtr) = recordPtr->nextPtr;	\
+    }
+				 
+
+#define FREE_RECORD(iPtr, recordPtr)					\
+    {									\
+	TEOV_callback *callbackPtr = recordPtr->callbackPtr;		\
+	if (TCL_NR_HAS_OBJ(recordPtr->type)) {		\
+	    Tcl_DecrRefCount(recordPtr->data.obj.objPtr);		\
+	}								\
+	while (callbackPtr) {						\
+	    callbackPtr = callbackPtr->nextPtr;				\
+	    TclSmallFree(recordPtr->callbackPtr);			\
+	}								\
+	TCLNR_FREE(((Tcl_Interp *)iPtr), recordPtr);			\
+    }
+
+#define VALID_NEW_REQUEST(recordPtr)				\
+    ( (recordPtr)->callbackPtr || ((recordPtr)->type != TCL_NR_NO_TYPE))
+
+#define CHECK_VALID_RETURN(iPtr, recordPtr)			\
+    ((TOP_RECORD(iPtr) == recordPtr)  &&			\
+	    CHECK_EXTRA(iPtr, recordPtr))
+
+#define READ_OBJV_RECORD(recordPtr)   /* TBD? Or read by hand (braille?) */
+
+
+/*
+ * functions
+ */
+
+#if 0
+/* built as static inline in tclProc.c. Do TclOO/Itcl need this? */
+MODULE_SCOPE int TclNR_BC  (Tcl_Interp * interp, ByteCode *codePtr,
+                           TclNR_PostProc *postProcPtr, ClientData clientData);
+#endif
+
+/* The following starts purges the stack popping TclStackAllocs down to where
+ * tosPtr has the requested value. Panics on failure.*/
+MODULE_SCOPE void TclStackPurge(Tcl_Interp *interp, Tcl_Obj **tosPtr);
+
+/*
+ * Tailcalls!
+ */
+
+MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclTailcallObjCmd;
+
+
+/*****************************************************************************
+ * Stuff that goes away: temp during devel
+ *****************************************************************************/
+
+#if USE_SMALL_ALLOC
+#define TCLNR_ALLOC(interp, ptr) TclSmallAlloc(sizeof(TEOV_record), ptr)
+#define TCLNR_FREE(interp, ptr)  TclSmallFree((ptr))
+#elif USE_STACK_ALLOC
+#define TCLNR_ALLOC(interp, ptr) (ptr = TclStackAlloc(interp, sizeof(TEOV_record)))
+#define TCLNR_FREE(interp, ptr)  TclStackFree(interp, (ptr))
+#else
+#define TCLNR_ALLOC(interp, size, ptr) (ptr = ((ClientData) ckalloc(sizeof(TEOV_record))))
+#define TCLNR_FREE(interp, ptr)  ckfree((char *) (ptr))
+#endif
+
+#if ENABLE_ASSERTS
+#include <assert.h>
+#else
+#define assert(expr)
+#endif
+
+#endif /* _TCLNONREC */
diff --git a/tests/NRE.test b/tests/NRE.test
new file mode 100644
index 0000000..e0ec9eb
--- /dev/null
+++ b/tests/NRE.test
@@ -0,0 +1,308 @@
+# Commands covered:  proc, apply, [interp alias], [namespce import], tailcall
+#
+# This file contains a collection of tests for the non-recursive executor that
+# avoids recursive calls to TEBC.
+#
+# Copyright (c) 2008 by Miguel Sofer.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: NRE.test,v 1.1 2008/07/13 09:04:54 msofer Exp $
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+    package require tcltest
+    namespace import -force ::tcltest::*
+}
+
+if {[testConstraint unix]} {
+    #
+    # Workaround for gnu-make bug http://savannah.gnu.org/bugs/?18396
+    #
+    # Do not let make set up too large a C stack for us, as it effectively
+    # disables the tests under some circumstances
+    #
+
+    set oldLimit [teststacklimit 2048]
+}
+
+
+testConstraint tailcall [llength [info commands ::tcl::unsupported::tailcall]]
+
+#
+# The first few tests will blow the C stack if the NR machinery is not working
+# properly: all these calls should execute within the same instance of TEBC,
+# and thus do not load the C stack. The nesting limit is given by how much the
+# Tcl execution stack can grow. 
+#
+
+interp recursionlimit {} 100000
+
+test NRE-1.1 {self-recursive procs} -setup {
+    proc a i {
+	if {[incr i] > 20000} {
+	    return $i
+	}
+	a $i
+    }
+} -body {
+    list [catch {a 0} msg] $msg
+} -cleanup {
+    rename a {}
+} -result {0 20001}
+
+test NRE-1.2 {self-recursive lambdas} -setup {
+    set a [list i {
+	if {[incr i] > 20000} {
+	    return $i
+	}
+	apply $::a $i
+    }]
+} -body {
+    list [catch {apply $a 0} msg] $msg
+} -cleanup {
+    unset a
+} -result {0 20001}
+
+test NRE-1.2.1 {self-recursive lambdas} -setup {
+    set a [list {} {
+	if {[incr ::i] > 20000} {
+	    return $::i
+	}
+	apply $::a
+    }]
+} -body {
+    set ::i 0
+    list [catch {apply $a} msg] $msg $::i
+} -cleanup {
+    unset a
+} -result {0 20001 20001}
+
+test NRE-1.3 {mutually recursive procs and lambdas} -setup {
+    proc a i {
+	apply $::b [incr i]
+    }
+    set b [list i {
+	if {[incr i] > 20000} {
+	    return $i
+	}
+	a $i
+    }]
+} -body {
+    list [catch {list [a 0] [apply $b 0]} msg] $msg
+} -cleanup {
+    rename a {}
+    unset b
+} -result {0 {20002 20001}}
+
+#
+# Test that aliases are non-recursive
+#
+
+test NRE-2.1 {alias is not recursive} -setup {
+    proc a i {
+	if {[incr i] > 20000} {
+	    return $i
+	}
+	b $i
+    }
+    interp alias {} b {} a
+} -body {
+    list [catch {list [a 0] [b 0]} msg] $msg
+} -cleanup {
+    rename a {}
+    rename b {}
+} -result {0 {20001 20001}}
+
+#
+# Test that imports are non-recursive
+#
+
+test NRE-3.1 {imports are not recursive} -setup {
+    namespace eval foo {
+	proc a i {
+	    if {[incr i] > 20000} {
+		return $i
+	    }
+	    ::a $i
+	}
+	namespace export a
+    }
+    namespace import foo::a
+    a 1
+} -body {
+    list [catch {a 0} msg] $msg
+} -cleanup {
+    rename a {}
+    namespace delete ::foo
+} -result {0 20001}
+
+
+test NRE-4.1 {ensembles are not recursive} -setup {
+    proc a i {
+	if {[incr i] > 20000} {
+	    return $i
+	}
+	b foo $i
+    }
+    namespace ensemble create \
+	-command b \
+	-map [list foo a]
+} -body {
+    list [catch {list [a 0] [b foo 0]} msg] $msg
+} -cleanup {
+    rename a {}
+    rename b {}
+} -result {0 {20001 20001}}
+
+
+test NRE-5.1 {[namespace eval] is not recursive} -setup {
+    namespace eval ::foo {
+	proc a i {
+	    if {[incr i] > 20000} {
+		return $i
+	    }
+	    namespace eval ::foo [list a $i]
+	}
+    }
+} -body {
+    list [catch {::foo::a 0} msg] $msg
+} -cleanup {
+    namespace delete ::foo
+} -result {0 20001}
+
+test NRE-5.2 {[namespace eval] is not recursive} -setup {
+    namespace eval ::foo {
+	proc a i {
+	    if {[incr i] > 20000} {
+		return $i
+	    }
+	    namespace eval ::foo "set x $i; a $i"
+	}
+    }
+} -body {
+    list [catch {::foo::a 0} msg] $msg
+} -cleanup {
+    namespace delete ::foo
+} -result {0 20001}
+
+
+test NRE-6.1 {[uplevel] is not recursive} -setup {
+    proc a i {
+	if {[incr i] > 20000} {
+	    return $i
+	}
+	uplevel 1 [list a $i]
+    }
+} -body {
+    list [catch {a 0} msg] $msg
+} -cleanup {
+    rename a {}
+} -result {0 20001}
+
+test NRE-6.2 {[uplevel] is not recursive} -setup {
+    proc a i {
+	if {[incr i] > 20000} {
+	    return $i
+	}
+	uplevel 1 "set x $i; a $i"
+    }
+} -body {
+    list [catch {a 0} msg] $msg
+} -cleanup {
+    rename a {}
+} -result {0 20001}
+
+#
+# NASTY BUG found by tcllib's interp package
+#
+
+test NRE-X.1 {eval in wrong interp} {
+    set i [interp create]
+    set res [$i eval {
+	set x {namespace children ::}
+	set y [list namespace children ::]
+	namespace delete {*}[{*}$y]
+	set j [interp create]
+	$j eval {namespace delete {*}[namespace children ::]}
+	namespace eval foo {}
+	set res [list [eval $x] [eval $y] [$j eval $x] [$j eval $y]]
+	interp delete $j
+	set res
+    }]
+    interp delete $i
+    set res
+} {::foo ::foo {} {}}
+
+#
+# Test tailcalls
+#
+namespace eval tcl::unsupported namespace export tailcall
+namespace import tcl::unsupported::tailcall
+
+test NRE-T.1 {tailcall} {tailcall} {
+    namespace eval a {
+	unset -nocomplain x
+	proc aset args {uplevel 1 [list set {*}$args]}
+	proc foo {} {tailcall aset x 1}
+    }
+    namespace eval b {
+	unset -nocomplain x
+	proc aset args {error b::aset}
+	proc moo {} {set x 0; ::a::foo; set x}
+    }
+    unset -nocomplain x
+    proc aset args {error ::aset}
+    ::b::moo
+} 1
+
+test NRE-T.2 {tailcall in non-proc} {tailcall} {
+    list [catch {namespace eval a [list tailcall set x 1]} msg] $msg
+} {1 {tailcall can only be called from a proc or lambda}}
+
+test NRE-T.3 {tailcall falls off tebc} {tailcall} {
+    unset -nocomplain x
+    proc foo {} {tailcall set x 1}
+    list [catch foo msg] $msg [set x]
+} {0 1 1}
+
+test NRE-T.4 {tailcall falls off tebc} {
+    set x 2
+    proc foo {} {tailcall set x 1}
+    foo
+    set x
+} 1
+
+test NRE-T.5 {tailcall falls off tebc} {
+    set x 2
+    namespace eval bar {
+	variable x 3
+	proc foo {} {tailcall set x 1}
+    }
+    foo
+    list $x $bar::x
+} {1 3}
+
+test NRE-T.6 {tailcall does remove callframes} {tailcall} {
+    proc foo {} {info level}
+    proc moo {} {tailcall foo}
+    proc boo {} {expr {[moo] - [info level]}}
+    boo
+} 1
+
+
+#
+# Test that ensembles are non-recursive
+#
+
+
+
+# cleanup
+::tcltest::cleanupTests
+
+if {[testConstraint unix]} {
+    teststacklimit $oldLimit
+}
+
+
+return