diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 7622398781..40ff4a3107 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -36,6 +36,7 @@ + listener/plugin: +- twice in completion list - accept multi-line input in listener - don't show listener on certain commands - NPE in ErrorHighlight diff --git a/library/compiler/assembly-x86.factor b/library/compiler/assembly-x86.factor index ad5ec4a90d..0f1d4fc36d 100644 --- a/library/compiler/assembly-x86.factor +++ b/library/compiler/assembly-x86.factor @@ -113,7 +113,7 @@ USE: combinators : [R]>R ( reg reg -- ) #! MOV INDIRECT TO . - HEX: 8b compile-byte swap 0 MOD-R/M ; + HEX: 8b compile-byte 0 MOD-R/M ; : R>[R] ( reg reg -- ) #! MOV TO INDIRECT . @@ -164,19 +164,20 @@ USE: combinators BIN: 100 BIN: 11 MOD-R/M compile-byte ; -: CMP-I-[R] ( imm reg -- ) - #! There are two forms of CMP we assemble - #! 83 38 03 cmpl $0x3,(%eax) - #! 81 38 33 33 33 00 cmpl $0x333333,(%eax) - over byte? [ +: CMP-I-R ( imm reg -- ) + #! There are three forms of CMP we assemble + #! 83 f8 03 cmpl $0x3,%eax + #! 81 fa 33 33 33 00 cmpl $0x333333,%edx + #! 3d 33 33 33 00 cmpl $0x333333,%eax + [ HEX: 83 compile-byte - BIN: 111 0 MOD-R/M - compile-byte + BIN: 111 BIN: 11 MOD-R/M + ] [ + HEX: 3d compile-byte ] [ HEX: 81 compile-byte - BIN: 111 0 MOD-R/M - compile-cell - ] ifte ; + BIN: 111 BIN: 11 MOD-R/M + ] byte/eax/cell ; : JUMP-FIXUP ( addr where -- ) #! Encode a relative offset to addr from where at where. diff --git a/library/compiler/compiler-macros.factor b/library/compiler/compiler-macros.factor index b5c9d50894..5b5f0aff19 100644 --- a/library/compiler/compiler-macros.factor +++ b/library/compiler/compiler-macros.factor @@ -30,30 +30,25 @@ USE: alien : LITERAL ( cell -- ) #! Push literal on data stack. - ESI I>[R] - 4 ESI R+I ; + 4 ESI R+I + ESI I>[R] ; : [LITERAL] ( cell -- ) #! Push complex literal on data stack by following an #! indirect pointer. + 4 ESI R+I EAX [I]>R - EAX ESI R>[R] - 4 ESI R+I ; + EAX ESI R>[R] ; : PUSH-DS ( -- ) #! Push contents of EAX onto datastack. - EAX ESI R>[R] - 4 ESI R+I ; - -: PEEK-DS ( -- ) - #! Peek datastack, store pointer to datastack top in EAX. - ESI EAX R>R - 4 EAX R-I ; + 4 ESI R+I + EAX ESI R>[R] ; : POP-DS ( -- ) #! Pop datastack, store pointer to datastack top in EAX. - PEEK-DS - EAX ESI R>R ; + ESI EAX [R]>R + 4 ESI R-I ; : SELF-CALL ( name -- ) #! Call named C function in Factor interpreter executable. @@ -61,14 +56,13 @@ USE: alien : TYPE ( -- ) #! Peek datastack, store type # in EAX. - PEEK-DS - EAX PUSH-[R] + ESI PUSH-[R] "type_of" SELF-CALL 4 ESP R+I ; : ARITHMETIC-TYPE ( -- ) #! Peek top two on datastack, store arithmetic type # in EAX. - PEEK-DS + ESI EAX R>R EAX PUSH-[R] 4 EAX R-I EAX PUSH-[R] diff --git a/library/compiler/ifte.factor b/library/compiler/ifte.factor index 5aa2af70bd..c66f7e390b 100644 --- a/library/compiler/ifte.factor +++ b/library/compiler/ifte.factor @@ -35,8 +35,8 @@ USE: lists : compile-test ( -- ) POP-DS - ! ptr to condition is now in EAX - f address EAX CMP-I-[R] ; + ! condition is now in EAX + f address EAX CMP-I-R ; : compile-f-test ( -- fixup ) #! Push addr where we write the branch target address. diff --git a/library/platform/native/boot-stage2.factor b/library/platform/native/boot-stage2.factor index 3a68c326ae..2aea3245ca 100644 --- a/library/platform/native/boot-stage2.factor +++ b/library/platform/native/boot-stage2.factor @@ -153,6 +153,7 @@ cpu "x86" = [ "/library/compiler/compiler.factor" "/library/compiler/ifte.factor" "/library/compiler/generic.factor" + "/library/compiler/stack.factor" "/library/compiler/interpret-only.factor" "/library/compiler/compile-all.factor" "/library/compiler/alien-types.factor" diff --git a/library/platform/native/stack.factor b/library/platform/native/stack.factor index e5ad4978ed..7a760204dc 100644 --- a/library/platform/native/stack.factor +++ b/library/platform/native/stack.factor @@ -37,7 +37,7 @@ USE: vectors : dupd ( x y -- x x y ) >r dup r> ; : swapd ( x y z -- y x z ) >r swap r> ; : transp ( x y z -- z y x ) swap rot ; -: 2swap ( x y z t -- z t x y ) rot >r rot r> ; +: 2nip ( x y z t -- z t ) >r >r drop drop r> r> ; : clear ( -- ) #! Clear the datastack. For interactive use only; invoking diff --git a/library/test/inference.factor b/library/test/inference.factor index da02f4a6c2..e77ef6d7ae 100644 --- a/library/test/inference.factor +++ b/library/test/inference.factor @@ -6,6 +6,7 @@ USE: stack USE: combinators USE: vectors USE: kernel +USE: lists [ 6 ] [ 6 gensym-vector vector-length ] unit-test @@ -57,3 +58,28 @@ USE: kernel [ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] ifte call ] unit-test-fails + +: infinite-loop infinite-loop ; + +[ [ infinite-loop ] infer ] unit-test-fails + +: simple-recursion-1 + dup [ simple-recursion-1 ] [ ] ifte ; + +[ [ 1 | 1 ] ] [ [ simple-recursion-1 ] infer ] unit-test + +: simple-recursion-2 + dup [ ] [ simple-recursion-2 ] ifte ; + +[ [ 1 | 1 ] ] [ [ simple-recursion-2 ] infer ] unit-test + +[ [ 2 | 1 ] ] [ [ 2list ] infer ] unit-test +[ [ 3 | 1 ] ] [ [ 3list ] infer ] unit-test +[ [ 2 | 1 ] ] [ [ append ] infer ] unit-test +[ [ 2 | 1 ] ] [ [ swons ] infer ] unit-test +[ [ 1 | 2 ] ] [ [ uncons ] infer ] unit-test +[ [ 1 | 1 ] ] [ [ unit ] infer ] unit-test +[ [ 1 | 2 ] ] [ [ unswons ] infer ] unit-test +! [ [ 1 | 1 ] ] [ [ last* ] infer ] unit-test +! [ [ 1 | 1 ] ] [ [ last ] infer ] unit-test +! [ [ 1 | 1 ] ] [ [ list? ] infer ] unit-test diff --git a/library/tools/inference.factor b/library/tools/inference.factor index e8310ba6a8..3ce44ee6c2 100644 --- a/library/tools/inference.factor +++ b/library/tools/inference.factor @@ -31,12 +31,14 @@ USE: errors USE: interpreter USE: kernel USE: lists +USE: logic USE: math USE: namespaces USE: stack USE: strings USE: vectors USE: words +USE: hashtables ! Word properties that affect inference: ! - infer-effect -- must be set. controls number of inputs @@ -45,8 +47,12 @@ USE: words ! - infer - quotation with custom inference behavior; ifte uses ! this. Word is passed on the stack. +! Amount of results we had to add to the datastack SYMBOL: d-in +! Amount of results we had to add to the callstack SYMBOL: r-in +! Recursive state. Alist maps words to base case effects +SYMBOL: recursive-state : gensym-vector ( n -- vector ) dup swap [ gensym over vector-push ] times ; @@ -65,7 +71,7 @@ SYMBOL: r-in : ensure-d ( count -- ) #! Ensure count of unknown results are on the stack. - meta-d get ensure meta-d set d-in +@ ; + meta-d get ensure meta-d set d-in +@ ; : consume-d ( count -- ) #! Remove count of elements. @@ -75,6 +81,9 @@ SYMBOL: r-in #! Push count of unknown results. [ gensym push-d ] times ; +: consume/produce ( [ in | out ] -- ) + unswons dup ensure-d consume-d produce-d ; + : standard-effect ( word [ in | out ] -- ) #! If a word does not have special inference behavior, we #! either execute the word in the meta interpreter (if it is @@ -83,7 +92,7 @@ SYMBOL: r-in over "meta-infer" word-property [ drop host-word ] [ - unswons consume-d produce-d drop + nip consume/produce ] ifte ; : apply-effect ( word [ in | out ] -- ) @@ -100,22 +109,49 @@ SYMBOL: r-in DEFER: (infer) +: apply-compound ( word -- ) + t over recursive-state acons@ + word-parameter (infer) + recursive-state uncons@ drop ; + : apply-word ( word -- ) - #! Apply the word's stack effect to the inferencer's state. + #! Apply the word's stack effect to the inferencer state. dup "infer-effect" word-property dup [ apply-effect ] [ - drop dup compound? [ - word-parameter (infer) + drop dup compound? [ apply-compound ] [ no-effect ] ifte + ] ifte ; + +: current-word ( -- word ) + #! Push word we're currently inferring effect of. + recursive-state get car car ; + +: no-base-case ( -- ) + current-word word-name + " does not have a base case." cat2 throw ; + +: recursive-word ( word effect -- ) + #! Handle a recursive call, by either applying a previously + #! inferred base case, or raising an error. + dup t = [ drop no-base-case ] [ nip consume/produce ] ifte ; + +: apply-object ( obj -- ) + #! Apply the object's stack effect to the inferencer state. + dup word? [ + dup recursive-state get assoc [ + recursive-word ] [ - no-effect - ] ifte + apply-word + ] ifte* + ] [ + push-d ] ifte ; : init-inference ( -- ) init-interpreter 0 d-in set - 0 r-in set ; + 0 r-in set + f recursive-state set ; : effect ( -- [ in | out ] ) #! After inference is finished, collect information. @@ -124,13 +160,9 @@ DEFER: (infer) : (infer) ( quot -- ) #! Recursive calls to this word are made for nested #! quotations. - [ dup word? [ apply-word ] [ push-d ] ifte ] each ; + [ apply-object ] each ; -: infer ( quot -- [ in | out ] ) - #! Stack effect of a quotation. - [ init-inference (infer) effect ] with-scope ; - -: infer-branch ( quot -- [ in-d | datastack ] ) +: (infer-branch) ( quot -- [ in-d | datastack ] ) #! Infer the quotation's effect, restoring the meta #! interpreter state afterwards. [ @@ -138,6 +170,10 @@ DEFER: (infer) d-in get meta-d get cons ] with-scope ; +: infer-branch ( quot -- [ in-d | datastack ] ) + #! Push f if inference failed. + [ (infer-branch) ] [ [ drop f ] when ] catch ; + : difference ( [ in | stack ] -- diff ) #! Stack height difference of infer-branch return value. uncons vector-length - ; @@ -175,10 +211,43 @@ DEFER: (infer) "Unbalanced ifte branches" throw ] ifte ; +: set-base ( [ in | stack ] -- ) + #! Set the base case of the current word. + recursive-state uncons@ car >r + uncons vector-length cons r> + recursive-state acons@ ; + +: recursive-branches ( false true fe te -- fe te ) + #! At least one of the branches did not have a computable + #! stack effect. Set the base case to the other branch, and + #! try again. + 2dup or [ + dup [ + dup set-base >r 2drop infer-branch r> + ] [ + drop dup set-base swap infer-branch rot drop + ] ifte + ] [ + no-base-case + ] ifte ; + +: infer-branches ( false true -- [ in | stack ] [ in | stack ] ) + #! Recursive stack effect inference is done here. If one of + #! the branches has an undecidable stack effect, we set the + #! base case to this stack effect and try again. + over infer-branch over infer-branch 2dup and [ + 2nip ( all good ) + ] [ + recursive-branches + ] ifte ; + : infer-ifte ( -- ) #! Infer effects for both branches, unify. - pop-d pop-d pop-d drop ( condition ) - >r infer-branch r> infer-branch unify ; + pop-d pop-d pop-d drop ( condition ) infer-branches unify ; + +: infer ( quot -- [ in | out ] ) + #! Stack effect of a quotation. + [ init-inference (infer) effect ] with-scope ; \ call [ pop-d (infer) ] "infer" set-word-property \ call [ 1 | 0 ] "infer-effect" set-word-property @@ -206,6 +275,13 @@ DEFER: (infer) \ rot t "meta-infer" set-word-property \ rot [ 3 | 3 ] "infer-effect" set-word-property +\ type [ 1 | 1 ] "infer-effect" set-word-property +\ eq? [ 2 | 1 ] "infer-effect" set-word-property + +\ car [ 1 | 1 ] "infer-effect" set-word-property +\ cdr [ 1 | 1 ] "infer-effect" set-word-property +\ cons [ 2 | 1 ] "infer-effect" set-word-property + \ fixnum+ [ 2 | 1 ] "infer-effect" set-word-property \ fixnum- [ 2 | 1 ] "infer-effect" set-word-property \ fixnum* [ 2 | 1 ] "infer-effect" set-word-property diff --git a/native/gc.c b/native/gc.c index f26ca948a8..0dcdc7999b 100644 --- a/native/gc.c +++ b/native/gc.c @@ -120,10 +120,10 @@ void collect_roots(void) copy_bignum_constants(); copy_object(&callframe); - for(ptr = ds_bot; ptr < ds; ptr += CELLS) + for(ptr = ds_bot; ptr <= ds; ptr += CELLS) copy_object((void*)ptr); - for(ptr = cs_bot; ptr < cs; ptr += CELLS) + for(ptr = cs_bot; ptr <= cs; ptr += CELLS) copy_object((void*)ptr); for(i = 0; i < USER_ENV; i++) diff --git a/native/run.h b/native/run.h index 4323d0a1ef..77235875df 100644 --- a/native/run.h +++ b/native/run.h @@ -49,41 +49,43 @@ CELL profile_depth; INLINE CELL dpop(void) { + CELL value = get(ds); ds -= CELLS; - return get(ds); + return value; } INLINE void drepl(CELL top) { - put(ds - CELLS,top); + put(ds,top); } INLINE void dpush(CELL top) { - put(ds,top); ds += CELLS; + put(ds,top); } INLINE CELL dpeek(void) { - return get(ds - CELLS); + return get(ds); } INLINE CELL cpop(void) { + CELL value = get(cs); cs -= CELLS; - return get(cs); + return value; } INLINE void cpush(CELL top) { - put(cs,top); cs += CELLS; + put(cs,top); } INLINE CELL cpeek(void) { - return get(cs - CELLS); + return get(cs); } INLINE void call(CELL quot) diff --git a/native/stack.c b/native/stack.c index 5f00912d91..97737b526c 100644 --- a/native/stack.c +++ b/native/stack.c @@ -2,12 +2,12 @@ void reset_datastack(void) { - ds = ds_bot; + ds = ds_bot - CELLS; } void reset_callstack(void) { - cs = cs_bot; + cs = cs_bot - CELLS; } void init_stacks(void) @@ -32,44 +32,44 @@ void primitive_dup(void) void primitive_swap(void) { CELL top = dpeek(); - CELL next = get(ds - CELLS * 2); - put(ds - CELLS,next); - put(ds - CELLS * 2,top); + CELL next = get(ds - CELLS); + put(ds,next); + put(ds - CELLS,top); } void primitive_over(void) { - dpush(get(ds - CELLS * 2)); + dpush(get(ds - CELLS)); } void primitive_pick(void) { - dpush(get(ds - CELLS * 3)); + dpush(get(ds - CELLS * 2)); } void primitive_nip(void) { CELL top = dpop(); - put(ds - CELLS,top); + put(ds,top); } void primitive_tuck(void) { CELL top = dpeek(); - CELL next = get(ds - CELLS * 2); - put(ds - CELLS * 2,top); - put(ds - CELLS,next); + CELL next = get(ds - CELLS); + put(ds - CELLS,top); + put(ds,next); dpush(top); } void primitive_rot(void) { CELL top = dpeek(); - CELL next = get(ds - CELLS * 2); - CELL next_next = get(ds - CELLS * 3); - put(ds - CELLS * 3,next); - put(ds - CELLS * 2,top); - put(ds - CELLS,next_next); + CELL next = get(ds - CELLS); + CELL next_next = get(ds - CELLS * 2); + put(ds - CELLS * 2,next); + put(ds - CELLS,top); + put(ds,next_next); } void primitive_to_r(void) @@ -84,7 +84,7 @@ void primitive_from_r(void) VECTOR* stack_to_vector(CELL bottom, CELL top) { - CELL depth = (top - bottom) / CELLS; + CELL depth = (top - bottom + CELLS) / CELLS; VECTOR* v = vector(depth); ARRAY* a = v->array; memcpy(a + 1,(void*)bottom,depth * CELLS); @@ -110,7 +110,7 @@ CELL vector_to_stack(VECTOR* vector, CELL bottom) CELL start = bottom; CELL len = vector->top * CELLS; memcpy((void*)start,vector->array + 1,len); - return start + len; + return start + len - CELLS; } void primitive_set_datastack(void) diff --git a/native/stack.h b/native/stack.h index 209455161d..061b97d92d 100644 --- a/native/stack.h +++ b/native/stack.h @@ -1,5 +1,5 @@ -#define STACK_UNDERFLOW(stack,bot) ((stack) < UNTAG(bot)) -#define STACK_OVERFLOW(stack,bot) ((stack) >= UNTAG(bot) + STACK_SIZE) +#define STACK_UNDERFLOW(stack,bot) ((stack) + CELLS < UNTAG(bot)) +#define STACK_OVERFLOW(stack,bot) ((stack) + CELLS >= UNTAG(bot) + STACK_SIZE) void reset_datastack(void); void reset_callstack(void);