diff options
| -rw-r--r-- | generic/tclNRE.h | 267 | ||||
| -rw-r--r-- | tests/NRE.test | 308 |
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 |