diff --git a/Makefile b/Makefile index 0a1f820663..05a5d8ce62 100644 --- a/Makefile +++ b/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 \ diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 5dd3e978bf..04e6960112 100644 --- a/TODO.FACTOR.txt +++ b/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 diff --git a/doc/handbook/dataflow.facts b/doc/handbook/dataflow.facts index 870ffefb42..aab568a9d4 100644 --- a/doc/handbook/dataflow.facts +++ b/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 - { "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:" - { $list - { "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 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 " { $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." } - { "The callframe is set to the " { $link cdr } ", and the loop continues." } -} +! { $list +! { "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:" +! { $list +! { "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 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 " { $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." } +! { "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." diff --git a/doc/handbook/objects.facts b/doc/handbook/objects.facts index d065ae6122..9f30019c38 100644 --- a/doc/handbook/objects.facts +++ b/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" diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index 41a7761129..5db09c30ea 100644 --- a/library/bootstrap/image.factor +++ b/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 ) -! quotation-type emit-array ; - -M: cons ' ( c -- tagged ) +M: quotation ' ( array -- pointer ) objects get [ quotation-type emit-array ] cache ; M: vector ' ( vector -- pointer ) diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index 9e76e44708..ef3f0d3955 100644 --- a/library/bootstrap/primitives.factor +++ b/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" } { "" "vectors" } { "rehash-string" "strings" } { "" "strings" } @@ -268,13 +267,6 @@ num-types f 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 { diff --git a/library/collections/arrays.facts b/library/collections/arrays.facts index 34a249e8ac..946bca7a00 100644 --- a/library/collections/arrays.facts +++ b/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: "( n elt -- array )" diff --git a/library/collections/sequence-combinators.factor b/library/collections/sequence-combinators.factor index 3cbaeb5a9c..38ab00d584 100644 --- a/library/collections/sequence-combinators.factor +++ b/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 -- ) - 1 standard-combination ; inline - -M: object each ( seq quot -- ) +: each ( seq quot -- | quot: elt -- ) 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 -- ? ) - 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 ) +: map ( seq quot -- seq | quot: elt -- elt ) 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 ) - 0 -rot find* ; +: find ( seq quot -- i elt | quot: elt -- ? ) + 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 ) [ diff --git a/library/collections/sequence-eq.factor b/library/collections/sequence-eq.factor index 55b1d48ed7..43412ebed0 100644 --- a/library/collections/sequence-eq.factor +++ b/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 = [ diff --git a/library/collections/sequences.factor b/library/collections/sequences.factor index cc2d49a4f4..1b3566df49 100644 --- a/library/collections/sequences.factor +++ b/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 ; diff --git a/library/collections/strings.facts b/library/collections/strings.facts index 9186dc9348..11db6e1aaa 100644 --- a/library/collections/strings.facts +++ b/library/collections/strings.facts @@ -1,4 +1,4 @@ -USING: arrays help kernel lists strings vectors ; +USING: arrays help kernel strings vectors ; HELP: "( n ch -- string )" { $values { "n" "a positive integer specifying string length" } { "elt" "an initial character" } } diff --git a/library/compiler/inference/known-words.factor b/library/compiler/inference/known-words.factor index 4175ac5070..061bf8dda7 100644 --- a/library/compiler/inference/known-words.factor +++ b/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 - \ [ [ integer ] [ vector ] ] "infer-effect" set-word-prop \ t "flushable" set-word-prop diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index b4dac28205..d865d1fb62 100644 --- a/library/syntax/prettyprint.factor +++ b/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 diff --git a/native/array.h b/native/array.h index 345f34f9be..c8c05645a3 100644 --- a/native/array.h +++ b/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) { diff --git a/native/cons.c b/native/cons.c deleted file mode 100644 index e3fb76cbed..0000000000 --- a/native/cons.c +++ /dev/null @@ -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)); -} diff --git a/native/cons.h b/native/cons.h deleted file mode 100644 index 49a566da76..0000000000 --- a/native/cons.h +++ /dev/null @@ -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); diff --git a/native/debug.c b/native/debug.c index 89719fea33..69a64f0091 100644 --- a/native/debug.c +++ b/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) { diff --git a/native/error.c b/native/error.c index fb33fea994..80a0efcd16 100644 --- a/native/error.c +++ b/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); diff --git a/native/error.h b/native/error.h index a0dee47e64..6044c13783 100644 --- a/native/error.h +++ b/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. -On x86, only the first is in a register; on PowerPC, all are. */ +/* Since longjmp restores registers, we must save all these values. */ 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); diff --git a/native/factor.c b/native/factor.c index 9b011cbafe..686e86fc75 100644 --- a/native/factor.c +++ b/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)); diff --git a/native/factor.h b/native/factor.h index ff3ad2dac2..f1ce165a22 100644 --- a/native/factor.h +++ b/native/factor.h @@ -58,8 +58,11 @@ CELL cs; /* TAGGED currently executing quotation */ CELL callframe; -/* TAGGED pointer to currently executing word */ -CELL executing; +/* UNTAGGED currently executing word in quotation */ +CELL callframe_scan; + +/* UNTAGGED end of quotation */ +CELL callframe_end; #include #include @@ -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" diff --git a/native/gc.c b/native/gc.c index c5a03e8c20..14c5389eb7 100644 --- a/native/gc.c +++ b/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); - copy_handle(&callframe); + collect_callframe_triple(&callframe,&callframe_scan,&callframe_end); 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); + + collect_callstack(stacks->call_region,stacks->call); + + collect_callframe_triple(&stacks->callframe, + &stacks->callframe_scan,&stacks->callframe_end); - copy_handle(&stacks->callframe); 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; - - if(headerp(get(scan))) - { - size = untagged_object_size(scan); - collect_object(scan); - } - else - { - size = CELLS; - copy_handle((CELL*)scan); - } - + CELL size = untagged_object_size(scan); + collect_object(scan); return scan + size; } diff --git a/native/image.c b/native/image.c index 081f09b960..61313eb2f6 100644 --- a/native/image.c +++ b/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; diff --git a/native/memory.c b/native/memory.c index d49184cdfd..1641a48c51 100644 --- a/native/memory.c +++ b/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)) - { - size = align8(untagged_object_size(heap_scan_ptr)); - type = untag_header(value); - } - else - { - size = CELLS * 2; - type = CONS_TYPE; - } - - heap_scan_ptr += size; + type = untag_header(value); + heap_scan_ptr += align8(untagged_object_size(heap_scan_ptr)); if(type < HEADER_TYPE) dpush(RETAG(obj,type)); diff --git a/native/memory.h b/native/memory.h index db71eedeb7..6fb90df963 100644 --- a/native/memory.h +++ b/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 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); + return untag_header(get(UNTAG(tagged))); } INLINE CELL type_of(CELL tagged) { - CELL tag = TAG(tagged); - if(tag == OBJECT_TYPE) - return object_type(tagged); + if(tagged == F) + return F_TYPE; + 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); diff --git a/native/primitives.c b/native/primitives.c index d87cde74bd..7c272e4e71 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -8,7 +8,6 @@ void* primitives[] = { primitive_call, primitive_ifte, primitive_dispatch, - primitive_cons, primitive_vector, primitive_rehash_string, primitive_sbuf, diff --git a/native/relocate.c b/native/relocate.c index c1dbd130f3..7ebaa9c089 100644 --- a/native/relocate.c +++ b/native/relocate.c @@ -44,17 +44,8 @@ void relocate_object(CELL relocating) INLINE CELL relocate_data_next(CELL relocating) { - CELL size = CELLS; - CELL cell = get(relocating); - - if(headerp(cell)) - { - size = untagged_object_size(relocating); - relocate_object(relocating); - } - else if(cell != F) - data_fixup((CELL*)relocating); - + CELL size = untagged_object_size(relocating); + relocate_object(relocating); return relocating + size; } diff --git a/native/run.c b/native/run.c index e5296fb74a..1d92f5fe7b 100644 --- a/native/run.c +++ b/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(); - executing = cpop(); + callframe_end = get(cs); + callframe_scan = get(cs - CELLS); + callframe = get(cs - CELLS * 2); + cs -= CELLS * 3; continue; } - callframe = (CELL)untag_cons(callframe); - next = get(callframe); - callframe = get(callframe + CELLS); + next = get(callframe_scan); + callframe_scan += 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 */ diff --git a/native/run.h b/native/run.h index 12a48020b3..4572c82961 100644 --- a/native/run.h +++ b/native/run.h @@ -76,17 +76,7 @@ INLINE void rpush(CELL top) put(rs,top); } -INLINE void call(CELL quot) -{ - /* tail call optimization */ - if(callframe != F) - { - cpush(executing); - cpush(callframe); - } - - callframe = quot; -} +void call(CELL quot); void handle_error(); void run(void); diff --git a/native/stack.c b/native/stack.c index 392975769a..86921a326b 100644 --- a/native/stack.c +++ b/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_ARRAY* a = untag_array_fast(v->array); + F_VECTOR *v = vector(depth); + 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; } diff --git a/native/stack.h b/native/stack.h index d5383b62f5..330afd6db8 100644 --- a/native/stack.h +++ b/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 */