Last traces of conses removed

Makefile

@@ -54,7 +54,7 @@ endif
 
 OBJS = $(PLAF_OBJS) native/array.o native/bignum.o \
 	native/s48_bignum.o \
-	native/complex.o native/cons.o native/error.o \
+	native/complex.o native/error.o \
 	native/factor.o native/fixnum.o \
 	native/float.o native/gc.o \
 	native/image.o native/memory.o \

TODO.FACTOR.txt

@@ -1,5 +1,4 @@
-should fix in 0.82:
+- method ordering and interpreter algorithm sections need updates
-
 - another i/o bug: on factorcode eventually all i/o times out
 - get factor running on mac intel
 

doc/handbook/dataflow.facts

@@ -1,4 +1,4 @@
-USING: errors help kernel lists namespaces threads words ;
+USING: errors help kernel namespaces threads words ;
 
 GLOSSARY: "stack" "see datastack" ;
 
@@ -50,20 +50,20 @@ GLOSSARY: "combinator" "a word taking quotations or other words as input" ;
 
 ARTICLE: "quotations" "Quotations and combinators"
 "An evaluator executes quotations. Quotations are lists, and since lists can contain any Factor object, they can contain words. It is words that give quotations their operational behavior, as you can see in the following description of the evaluator algorithm."
-{ $list
+! { $list
-    { "If the callframe is " { $link f } ", the callstack is popped and becomes the new call frame." }
+!     { "If the callframe is " { $link f } ", the callstack is popped and becomes the new call frame." }
-    { "If the " { $link car } " of the callframe is a word, the word is executed:"
+!     { "If the " { $link car } " of the callframe is a word, the word is executed:"
-        { $list
+!         { $list
-            { "If the word is a symbol, it is pushed on the datastack. See " { $link "symbols" } }
+!             { "If the word is a symbol, it is pushed on the datastack. See " { $link "symbols" } }
-            { "If the word is a compound definition, the current callframe is pushed on the callstack, and the new callframe becomes the word definition. See " { $link "colon-definition" } }
+!             { "If the word is a compound definition, the current callframe is pushed on the callstack, and the new callframe becomes the word definition. See " { $link "colon-definition" } }
-            { "If the word is compiled or primitive, the interpreter jumps to a machine code definition. See " { $link "primitives" } }
+!             { "If the word is compiled or primitive, the interpreter jumps to a machine code definition. See " { $link "primitives" } }
-            { "If the word is undefined, an error is raised. See " { $link "deferred" } }
+!             { "If the word is undefined, an error is raised. See " { $link "deferred" } }
-        }
+!         }
-    }
+!     }
-    { "If the " { $link car } " of the callframe is a wrapper, the wrapped object is pushed on the datastack. Wrappers arise from the " { $link POSTPONE: \ } " parsing word." }
+!     { "If the " { $link car } " of the callframe is a wrapper, the wrapped object is pushed on the datastack. Wrappers arise from the " { $link POSTPONE: \ } " parsing word." }
-    { "Otherwise, the " { $link car } " of the call frame is pushed on the datastack." }
+!     { "Otherwise, the " { $link car } " of the call frame is pushed on the datastack." }
-    { "The callframe is set to the " { $link cdr } ", and the loop continues." }
+!     { "The callframe is set to the " { $link cdr } ", and the loop continues." }
-}
+! }
 "The interpreter performs the above steps literally. The compiler generates machine code which perform the steps in a more efficient manner than the interpreter."
 $terpri
 "The following pair of words are central. They invoke the evaluator reflectively, allowing higher-order programming and meta-programming techniques that lie at the heart of Factor's expressive power."

doc/handbook/objects.facts

@@ -1,4 +1,4 @@
-USING: generic help kernel lists sequences ;
+USING: generic help kernel sequences ;
 GLOSSARY: "object" "a datum which may appear on the stack" ;
 
 ARTICLE: "objects" "Objects"

library/bootstrap/image.factor

@@ -10,7 +10,7 @@
 ! format.
 
 USING: alien arrays errors generic hashtables
-hashtables-internals help io kernel kernel-internals lists math
+hashtables-internals help io kernel kernel-internals math
 namespaces parser prettyprint sequences sequences-internals
 strings vectors words ;
 IN: image
@@ -257,10 +257,7 @@ M: tuple ' ( tuple -- pointer )
 M: array ' ( array -- pointer )
     array-type emit-array ;
 
-! M: quotation ' ( array -- pointer )
+M: quotation ' ( array -- pointer )
-!     quotation-type emit-array ;
-
-M: cons ' ( c -- tagged )
     objects get [ quotation-type emit-array ] cache ;
 
 M: vector ' ( vector -- pointer )

library/bootstrap/primitives.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: image
 USING: alien arrays generic hashtables help io kernel
-kernel-internals lists math namespaces parser sequences strings
+kernel-internals math namespaces parser sequences strings
 vectors words ;
 
 ! Some very tricky code creating a bootstrap embryo in the
@@ -44,7 +44,6 @@ call
     { "call" "kernel"                       }
     { "if" "kernel"                         }
     { "dispatch" "kernel-internals"         }
-    { "cons" "lists"                        }
     { "<vector>" "vectors"                  }
     { "rehash-string" "strings"             }
     { "<sbuf>" "strings"                    }
@@ -268,13 +267,6 @@ num-types f <array> builtins set
 "bignum" "math" create 1 "bignum?" "math" create { } define-builtin
 "bignum" "math" create ">bignum" "math" lookup unit "coercer" set-word-prop
 
-"cons?" "lists" create t "inline" set-word-prop
-"cons" "lists" create 2 "cons?" "lists" create
-{
-    { 0 object { "car" "lists" } f }
-    { 1 object { "cdr" "lists" } f }
-} define-builtin
-
 "ratio?" "math" create t "inline" set-word-prop
 "ratio" "math" create 4 "ratio?" "math" create
 {

library/collections/arrays.facts

@@ -1,5 +1,5 @@
 IN: arrays
-USING: help kernel kernel-internals lists prettyprint strings
+USING: help kernel kernel-internals prettyprint strings
 vectors ;
 
 HELP: <array> "( n elt -- array )"

library/collections/sequence-combinators.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005 Slava Pestov.
+! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: sequences-internals
 USING: arrays generic kernel kernel-internals math sequences
@@ -39,13 +39,10 @@ vectors ;
 
 IN: sequences
 
-G: each ( seq quot -- | quot: elt -- )
+: each ( seq quot -- | quot: elt -- )
-    1 standard-combination ; inline
-
-M: object each ( seq quot -- )
     swap dup length [
         [ swap nth-unsafe swap call ] 3keep
-    ] repeat 2drop ;
+    ] repeat 2drop ; inline
 
 : each-with ( obj seq quot -- | quot: obj elt -- )
     swap [ with ] each 2drop ; inline
@@ -53,16 +50,9 @@ M: object each ( seq quot -- )
 : reduce ( seq identity quot -- value | quot: x y -- z )
     swapd each ; inline
 
-G: find ( seq quot -- i elt | quot: elt -- ? )
+: map ( seq quot -- seq | quot: elt -- elt )
-    1 standard-combination ; inline
-
-: find-with ( obj seq quot -- i elt | quot: elt -- ? )
-    swap [ with rot ] find 2swap 2drop ; inline
-
-G: map 1 standard-combination ; inline
-
-M: object map ( seq quot -- seq )
     swap [ dup length [ (map) ] collect ] keep like 2nip ;
+    inline
 
 : map-with ( obj list quot -- list | quot: obj elt -- elt )
     swap [ with rot ] map 2nip ; inline
@@ -110,8 +100,11 @@ M: object map ( seq quot -- seq )
 : find-with* ( obj i seq quot -- i elt | quot: elt -- ? )
     -rot [ with rot ] find* 2swap 2drop ; inline
 
-M: object find ( seq quot -- i elt )
+: find ( seq quot -- i elt | quot: elt -- ? )
-    0 -rot find* ;
+    0 -rot find* ; inline
+
+: find-with ( obj seq quot -- i elt | quot: elt -- ? )
+    swap [ with rot ] find 2swap 2drop ; inline
 
 : find-last* ( i seq quot -- i elt )
     [

library/collections/sequence-eq.factor

@@ -4,7 +4,7 @@ IN: sequences
 USING: arrays kernel math sequences-internals strings
 vectors ;
 
-UNION: sequence array string sbuf vector ;
+UNION: sequence array string sbuf vector quotation ;
 
 : sequence= ( seq seq -- ? )
     2dup [ length ] 2apply = [

library/collections/sequences.factor

@@ -47,6 +47,11 @@ M: object set-nth-unsafe set-nth ;
     pick pick >r >r >r swap nth-unsafe
     r> call r> r> swap set-nth-unsafe ; inline
 
+! The f object supports the sequence protocol trivially
+M: f length drop 0 ;
+M: f nth nip ;
+M: f nth-unsafe nip ;
+
 ! Integers support the sequence protocol
 M: integer length ;
 M: integer nth drop ;

library/collections/strings.facts

@@ -1,4 +1,4 @@
-USING: arrays help kernel lists strings vectors ;
+USING: arrays help kernel strings vectors ;
 
 HELP: <string> "( n ch -- string )"
 { $values { "n" "a positive integer specifying string length" } { "elt" "an initial character" } }

library/compiler/inference/known-words.factor

@@ -1,7 +1,7 @@
 IN: inference
 USING: arrays alien assembler errors generic hashtables
 hashtables-internals interpreter io io-internals kernel
-kernel-internals lists math math-internals memory parser
+kernel-internals math math-internals memory parser
 sequences strings vectors words prettyprint ;
 
 \ declare [
@@ -73,10 +73,6 @@ sequences strings vectors words prettyprint ;
 ] "infer" set-word-prop
 
 ! Stack effects for all primitives
-\ cons [ [ object object ] [ cons ] ] "infer-effect" set-word-prop
-\ cons t "foldable" set-word-prop
-\ cons t "flushable" set-word-prop
-
 \ <vector> [ [ integer ] [ vector ] ] "infer-effect" set-word-prop
 \ <vector> t "flushable" set-word-prop
 

library/syntax/prettyprint.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2003, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: prettyprint
-USING: alien arrays generic hashtables io kernel lists math
+USING: alien arrays generic hashtables io kernel math
 namespaces parser sequences strings styles vectors words ;
 
 ! State

native/array.h

@@ -43,6 +43,7 @@ void primitive_array_to_tuple(void);
 void primitive_tuple_to_array(void);
 
 #define AREF(array,index) ((CELL)(array) + sizeof(F_ARRAY) + (index) * CELLS)
+#define UNAREF(array,ptr) (((CELL)(ptr)-(CELL)(array)-sizeof(F_ARRAY)) / CELLS)
 
 INLINE CELL array_capacity(F_ARRAY* array)
 {

native/cons.c

@@ -1,18 +0,0 @@
-#include "factor.h"
-
-CELL cons(CELL car, CELL cdr)
-{
-	F_CONS* cons = allot(sizeof(F_CONS));
-	cons->car = car;
-	cons->cdr = cdr;
-	return tag_cons(cons);
-}
-
-void primitive_cons(void)
-{
-	CELL car, cdr;
-	maybe_gc(sizeof(F_CONS));
-	cdr = dpop();
-	car = dpop();
-	dpush(cons(car,cdr));
-}

native/cons.h

@@ -1,19 +0,0 @@
-typedef struct {
-	CELL car;
-	CELL cdr;
-} F_CONS;
-
-INLINE F_CONS* untag_cons(CELL tagged)
-{
-	type_check(CONS_TYPE,tagged);
-	return (F_CONS*)UNTAG(tagged);
-}
-
-INLINE CELL tag_cons(F_CONS* cons)
-{
-	return RETAG(cons,CONS_TYPE);
-}
-
-CELL cons(CELL car, CELL cdr);
-
-void primitive_cons(void);

native/debug.c

@@ -1,26 +1,5 @@
 #include "factor.h"
 
-void print_cons(CELL cons)
-{
-	fprintf(stderr,"[ ");
-
-	do
-	{
-		print_obj(untag_cons(cons)->car);
-		fprintf(stderr," ");
-		cons = untag_cons(cons)->cdr;
-	}
-	while(TAG(cons) == CONS_TYPE);
-
-	if(cons != F)
-	{
-		fprintf(stderr,"| ");
-		print_obj(cons);
-		fprintf(stderr," ");
-	}
-	fprintf(stderr,"]");
-}
-
 void print_word(F_WORD* word)
 {
 	if(type_of(word->name) == STRING_TYPE)
@@ -61,9 +40,6 @@ void print_obj(CELL obj)
 	case FIXNUM_TYPE:
 		fprintf(stderr,"%ld",untag_fixnum_fast(obj));
 		break;
-	case CONS_TYPE:
-		print_cons(obj);
-		break;
 	case WORD_TYPE:
 		print_word(untag_word(obj));
 		break;
@@ -244,9 +220,6 @@ void factorbug(void)
 			fprintf(stderr,"Call frame:\n");
 			print_obj(callframe);
 			fprintf(stderr,"\n");
-			fprintf(stderr,"Executing:\n");
-			print_obj(executing);
-			fprintf(stderr,"\n");
 		}
 		else if(strcmp(cmd,"e") == 0)
 		{

native/error.c

@@ -33,9 +33,6 @@ void throw_error(CELL error, bool keep_stacks)
 	thrown_keep_stacks = keep_stacks;
 	thrown_ds = ds;
 	thrown_rs = rs;
-	thrown_cs = cs;
-	thrown_callframe = callframe;
-	thrown_executing = executing;
 
 	/* Return to run() method */
 	LONGJMP(stack_chain->toplevel,1);

native/error.h

@@ -24,13 +24,9 @@ bool throwing;
 longjmps back to the top-level. */
 CELL thrown_error;
 CELL thrown_keep_stacks;
-/* Since longjmp restores registers, we must save all these values.
+/* Since longjmp restores registers, we must save all these values. */
-On x86, only the first is in a register; on PowerPC, all are. */
 CELL thrown_ds;
 CELL thrown_rs;
-CELL thrown_cs;
-CELL thrown_callframe;
-CELL thrown_executing;
 
 void fatal_error(char* msg, CELL tagged);
 void critical_error(char* msg, CELL tagged);

native/factor.c

@@ -11,9 +11,10 @@ void init_factor(const char* image,
 	init_stacks(ds_size,rs_size,cs_size);
 	/* callframe must be valid in case load_image() does GC */
 	callframe = F;
+	callframe_scan = callframe_end = 0;
 	thrown_error = F;
 	load_image(image,literal_size);
-	callframe = userenv[BOOT_ENV];
+	call(userenv[BOOT_ENV]);
 	init_c_io();
 	init_signals();
 	userenv[CPU_ENV] = tag_object(from_c_string(FACTOR_CPU_STRING));

native/factor.h

@@ -58,8 +58,11 @@ CELL cs;
 /* TAGGED currently executing quotation */
 CELL callframe;
 
-/* TAGGED pointer to currently executing word */
+/* UNTAGGED currently executing word in quotation */
-CELL executing;
+CELL callframe_scan;
+
+/* UNTAGGED end of quotation */
+CELL callframe_end;
 
 #include <errno.h>
 #include <fcntl.h>
@@ -100,7 +103,6 @@ CELL executing;
 #include "word.h"
 #include "run.h"
 #include "signal.h"
-#include "cons.h"
 #include "fixnum.h"
 #include "array.h"
 #include "s48_bignumint.h"

native/gc.c

@@ -64,6 +64,16 @@ void init_arena(CELL gens, CELL young_size, CELL aging_size)
 	cards_scanned = 0;
 }
 
+void collect_callframe_triple(CELL *callframe,
+	CELL *callframe_scan, CELL *callframe_end)
+{
+	*callframe_scan -= *callframe;
+	*callframe_end -= *callframe;
+	copy_handle(callframe);
+	*callframe_scan += *callframe;
+	*callframe_end += *callframe;
+}
+
 void collect_stack(BOUNDED_BLOCK *region, CELL top)
 {
 	CELL bottom = region->start;
@@ -73,6 +83,16 @@ void collect_stack(BOUNDED_BLOCK *region, CELL top)
 		copy_handle((CELL*)ptr);
 }
 
+void collect_callstack(BOUNDED_BLOCK *region, CELL top)
+{
+	CELL bottom = region->start;
+	CELL ptr;
+
+	for(ptr = bottom; ptr <= top; ptr += CELLS * 3)
+		collect_callframe_triple((CELL*)ptr,
+			(CELL*)ptr + 1, (CELL*)ptr + 2);
+}
+
 void collect_roots(void)
 {
 	int i;
@@ -82,8 +102,7 @@ void collect_roots(void)
 	copy_handle(&bignum_zero);
 	copy_handle(&bignum_pos_one);
 	copy_handle(&bignum_neg_one);
-	copy_handle(&executing);
+	collect_callframe_triple(&callframe,&callframe_scan,&callframe_end);
-	copy_handle(&callframe);
 
 	save_stacks();
 	stacks = stack_chain;
@@ -92,9 +111,12 @@ void collect_roots(void)
 	{
 		collect_stack(stacks->data_region,stacks->data);
 		collect_stack(stacks->retain_region,stacks->retain);
-		collect_stack(stacks->call_region,stacks->call);
 		
-		copy_handle(&stacks->callframe);
+		collect_callstack(stacks->call_region,stacks->call);
+
+		collect_callframe_triple(&stacks->callframe,
+			&stacks->callframe_scan,&stacks->callframe_end);
+
 		copy_handle(&stacks->catch_save);
 
 		stacks = stacks->next;
@@ -212,19 +234,8 @@ INLINE void collect_object(CELL scan)
 
 CELL collect_next(CELL scan)
 {
-	CELL size;
+	CELL size = untagged_object_size(scan);
-	
+	collect_object(scan);
-	if(headerp(get(scan)))
-	{
-		size = untagged_object_size(scan);
-		collect_object(scan);
-	}
-	else
-	{
-		size = CELLS;
-		copy_handle((CELL*)scan);
-	}
-
 	return scan + size;
 }
 

native/image.c

@@ -5,7 +5,6 @@ void init_objects(HEADER *h)
 	int i;
 	for(i = 0; i < USER_ENV; i++)
 		userenv[i] = F;
-	executing = F;
 	userenv[GLOBAL_ENV] = h->global;
 	userenv[BOOT_ENV] = h->boot;
 	T = h->t;

native/memory.c

@@ -15,9 +15,6 @@ CELL object_size(CELL pointer)
 	case BIGNUM_TYPE:
 		size = untagged_object_size(UNTAG(pointer));
 		break;
-	case CONS_TYPE:
-		size = sizeof(F_CONS);
-		break;
 	case OBJECT_TYPE:
 		if(pointer == F)
 			size = 0;
@@ -181,7 +178,7 @@ void primitive_next_object(void)
 {
 	CELL value = get(heap_scan_ptr);
 	CELL obj = heap_scan_ptr;
-	CELL size, type;
+	CELL type;
 
 	if(!heap_scan)
 		general_error(ERROR_HEAP_SCAN,F,F,true);
@@ -192,18 +189,8 @@ void primitive_next_object(void)
 		return;
 	}
 	
-	if(headerp(value))
+	type = untag_header(value);
-	{
+	heap_scan_ptr += align8(untagged_object_size(heap_scan_ptr));
-		size = align8(untagged_object_size(heap_scan_ptr));
-		type = untag_header(value);
-	}
-	else
-	{
-		size = CELLS * 2;
-		type = CONS_TYPE;
-	}
-
-	heap_scan_ptr += size;
 
 	if(type < HEADER_TYPE)
 		dpush(RETAG(obj,type));

native/memory.h

@@ -42,7 +42,7 @@ INLINE void bput(CELL where, BYTE what)
 
 INLINE CELL align8(CELL a)
 {
-	return ((a & 7) == 0) ? a : ((a + 8) & ~7);
+	return (a + 7) & ~7;
 }
 
 #define TAG_MASK 7
@@ -54,7 +54,6 @@ INLINE CELL align8(CELL a)
 /*** Tags ***/
 #define FIXNUM_TYPE 0
 #define BIGNUM_TYPE 1
-#define CONS_TYPE 2
 #define OBJECT_TYPE 3
 #define RATIO_TYPE 4
 #define FLOAT_TYPE 5
@@ -89,13 +88,6 @@ CELL T;
 
 #define SLOT(obj,slot) ((obj) + (slot) * CELLS)
 
-INLINE bool headerp(CELL cell)
-{
-	return (cell != F
-		&& TAG(cell) == OBJECT_TYPE
-		&& cell < RETAG(TYPE_COUNT << TAG_BITS,OBJECT_TYPE));
-}
-
 INLINE CELL tag_header(CELL cell)
 {
 	return RETAG(cell << TAG_BITS,OBJECT_TYPE);
@@ -113,35 +105,23 @@ INLINE CELL tag_object(void* cell)
 
 INLINE CELL object_type(CELL tagged)
 {
-	if(tagged == F)
+	return untag_header(get(UNTAG(tagged)));
-		return F_TYPE;
-	else
-		return untag_header(get(UNTAG(tagged)));
-}
-
-INLINE void type_check(CELL type, CELL tagged)
-{
-	if(type < HEADER_TYPE)
-	{
-		if(TAG(tagged) == type)
-			return;
-	}
-	else if(TAG(tagged) == OBJECT_TYPE
-		&& object_type(tagged) == type)
-	{
-		return;
-	}
-
-	type_error(type,tagged);
 }
 
 INLINE CELL type_of(CELL tagged)
 {
-	CELL tag = TAG(tagged);
+	if(tagged == F)
-	if(tag == OBJECT_TYPE)
+		return F_TYPE;
-		return object_type(tagged);
+	else if(TAG(tagged) == FIXNUM_TYPE)
+		return FIXNUM_TYPE;
 	else
-		return tag;
+		return object_type(tagged);
+}
+
+INLINE void type_check(CELL type, CELL tagged)
+{
+	if(type_of(tagged) != type)
+		type_error(type,tagged);
 }
 
 CELL untagged_object_size(CELL pointer);

native/primitives.c

@@ -8,7 +8,6 @@ void* primitives[] = {
 	primitive_call,
 	primitive_ifte,
 	primitive_dispatch,
-	primitive_cons,
 	primitive_vector,
 	primitive_rehash_string,
 	primitive_sbuf,

native/relocate.c

@@ -44,17 +44,8 @@ void relocate_object(CELL relocating)
 
 INLINE CELL relocate_data_next(CELL relocating)
 {
-	CELL size = CELLS;
+	CELL size = untagged_object_size(relocating);
-	CELL cell = get(relocating);
+	relocate_object(relocating);
-
-	if(headerp(cell))
-	{
-		size = untagged_object_size(relocating);
-		relocate_object(relocating);
-	}
-	else if(cell != F)
-		data_fixup((CELL*)relocating);
-
 	return relocating + size;
 }
 

native/run.c

@@ -5,6 +5,30 @@ INLINE void execute(F_WORD* word)
 	((XT)(word->xt))(word);
 }
 
+void call(CELL quot)
+{
+	F_ARRAY *untagged;
+
+	if(quot == F)
+		return;
+
+	type_check(QUOTATION_TYPE,quot);
+
+	/* tail call optimization */
+	if(callframe_scan < callframe_end)
+	{
+		put(cs + CELLS,callframe);
+		put(cs + CELLS * 2,callframe_scan);
+		put(cs + CELLS * 3,callframe_end);
+		cs += CELLS * 3;
+	}
+
+	callframe = quot;
+	untagged = (F_ARRAY*)UNTAG(quot);
+	callframe_scan = AREF(untagged,0);
+	callframe_end = AREF(untagged,array_capacity(untagged));
+}
+
 /* Called from platform_run() */
 void handle_error(void)
 {
@@ -13,17 +37,10 @@ void handle_error(void)
 		if(thrown_keep_stacks)
 		{
 			ds = thrown_ds;
-			cs = thrown_cs;
 			rs = thrown_rs;
-			callframe = thrown_callframe;
-			executing = thrown_executing;
 		}
 		else
-		{
 			fix_stacks();
-			callframe = F;
-			executing = F;
-		}
 
 		dpush(thrown_error);
 		/* Notify any 'catch' blocks */
@@ -38,19 +55,20 @@ void run(void)
 
 	for(;;)
 	{
-		if(callframe == F)
+		if(callframe_scan == callframe_end)
 		{
 			if(cs_bot - cs == CELLS)
 				return;
 
-			callframe = cpop();
+			callframe_end = get(cs);
-			executing = cpop();
+			callframe_scan = get(cs - CELLS);
+			callframe = get(cs - CELLS * 2);
+			cs -= CELLS * 3;
 			continue;
 		}
 
-		callframe = (CELL)untag_cons(callframe);
+		next = get(callframe_scan);
-		next = get(callframe);
+		callframe_scan += CELLS;
-		callframe = get(callframe + CELLS);
 
 		switch(type_of(next))
 		{
@@ -91,7 +109,6 @@ void undefined(F_WORD* word)
 void docol(F_WORD* word)
 {
 	call(word->def);
-	executing = tag_object(word);
 }
 
 /* pushes word parameter */

native/run.h

@@ -76,17 +76,7 @@ INLINE void rpush(CELL top)
 	put(rs,top);
 }
 
-INLINE void call(CELL quot)
+void call(CELL quot);
-{
-	/* tail call optimization */
-	if(callframe != F)
-	{
-		cpush(executing);
-		cpush(callframe);
-	}
-
-	callframe = quot;
-}
 
 void handle_error();
 void run(void);

native/stack.c

@@ -61,6 +61,8 @@ void nest_stacks(void)
 	new_stacks->cards_offset = cards_offset;
 
 	new_stacks->callframe = callframe;
+	new_stacks->callframe_scan = callframe_scan;
+	new_stacks->callframe_end = callframe_end;
 	new_stacks->catch_save = userenv[CATCHSTACK_ENV];
 
 	new_stacks->data_region = alloc_bounded_block(ds_size);
@@ -71,6 +73,7 @@ void nest_stacks(void)
 	stack_chain = new_stacks;
 
 	callframe = F;
+	callframe_scan = callframe_end = 0;
 	reset_datastack();
 	reset_retainstack();
 	reset_callstack();
@@ -92,6 +95,8 @@ void unnest_stacks(void)
 	cards_offset = old_stacks->cards_offset;
 
 	callframe = old_stacks->callframe;
+	callframe_scan = old_stacks->callframe_scan;
+	callframe_end = old_stacks->callframe_end;
 	userenv[CATCHSTACK_ENV] = old_stacks->catch_save;
 
 	stack_chain = old_stacks->next;
@@ -239,8 +244,8 @@ void primitive_from_r(void)
 F_VECTOR* stack_to_vector(CELL bottom, CELL top)
 {
 	CELL depth = (top - bottom + CELLS) / CELLS;
-	F_VECTOR* v = vector(depth);
+	F_VECTOR *v = vector(depth);
-	F_ARRAY* a = untag_array_fast(v->array);
+	F_ARRAY *a = untag_array_fast(v->array);
 	memcpy(a + 1,(void*)bottom,depth * CELLS);
 	v->top = tag_fixnum(depth);
 	return v;
@@ -261,7 +266,26 @@ void primitive_retainstack(void)
 void primitive_callstack(void)
 {
 	maybe_gc(0);
-	dpush(tag_object(stack_to_vector(cs_bot,cs)));
+	
+	CELL depth = (cs - cs_bot + CELLS) / CELLS;
+	F_VECTOR *v = vector(depth);
+	F_ARRAY *a = untag_array_fast(v->array);
+	CELL i;
+	CELL ptr = cs_bot;
+	
+	for(i = 0; i < depth; i += 3, ptr += 3 * CELLS)
+	{
+		CELL quot = get(ptr);
+		CELL untagged = UNTAG(quot);
+		CELL position = UNAREF(untagged,get(ptr + CELLS));
+		CELL end = UNAREF(untagged,get(ptr + CELLS * 2));
+		put(AREF(a,i),quot);
+		put(AREF(a,i + 1),tag_fixnum(position));
+		put(AREF(a,i + 2),tag_fixnum(end));
+	}
+
+	v->top = tag_fixnum(depth);
+	dpush(tag_object(v));
 }
 
 /* returns pointer to top of stack */
@@ -285,5 +309,33 @@ void primitive_set_retainstack(void)
 
 void primitive_set_callstack(void)
 {
-	cs = vector_to_stack(untag_vector(dpop()),cs_bot);
+	F_VECTOR *v = untag_vector(dpop());
+	F_ARRAY *a = untag_array_fast(v->array);
+
+	CELL depth = untag_fixnum_fast(v->top);
+	depth -= (depth % 3);
+
+	CELL i, ptr;
+	for(i = 0, ptr = cs_bot; i < depth; i += 3, ptr += 3 * CELLS)
+	{
+		CELL quot = get(AREF(a,i));
+		type_check(QUOTATION_TYPE,quot);
+
+		F_ARRAY *untagged = (F_ARRAY*)UNTAG(quot);
+		CELL length = array_capacity(untagged);
+
+		F_FIXNUM position = to_fixnum(get(AREF(a,i + 1)));
+		F_FIXNUM end = to_fixnum(get(AREF(a,i + 2)));
+
+		if(end < 0) end = 0;
+		if(end > length) end = length;
+		if(position < 0) position = 0;
+		if(position > end) position = end;
+
+		put(ptr,quot);
+		put(ptr + CELLS,AREF(untagged,position));
+		put(ptr + CELLS * 2,AREF(untagged,end));
+	}
+
+	cs = cs_bot + depth * CELLS - CELLS;
 }

native/stack.h

@@ -19,6 +19,8 @@ typedef struct _STACKS {
 	BOUNDED_BLOCK *call_region;
 	/* saved callframe on entry to callback */
 	CELL callframe;
+	CELL callframe_scan;
+	CELL callframe_end;
 	/* saved catchstack on entry to callback */
 	CELL catch_save;
 	/* saved cards_offset register on entry to callback */