\r
+ listener/plugin:\r
\r
+- twice in completion list\r
- accept multi-line input in listener\r
- don't show listener on certain commands\r
- NPE in ErrorHighlight\r
: [R]>R ( reg reg -- )
#! MOV INDIRECT <reg> TO <reg>.
- HEX: 8b compile-byte swap 0 MOD-R/M ;
+ HEX: 8b compile-byte 0 MOD-R/M ;
: R>[R] ( reg reg -- )
#! MOV <reg> TO INDIRECT <reg>.
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.
: 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.
: 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]
: 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.
"/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"
: 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
USE: combinators
USE: vectors
USE: kernel
+USE: lists
[ 6 ] [ 6 gensym-vector vector-length ] unit-test
[
[ [ 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
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
! - 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 <vector> swap [ gensym over vector-push ] times ;
: 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.
#! 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
over "meta-infer" word-property [
drop host-word
] [
- unswons consume-d produce-d drop
+ nip consume/produce
] ifte ;
: apply-effect ( word [ in | out ] -- )
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.
: (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.
[
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 - ;
"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
\ 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
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++)
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)
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)
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)
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);
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)
-#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);
projects / factor.git / commitdiff