steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

preliminary implementation of recursive effect deduction, compiler work

cvs
Slava Pestov 2004-11-07 02:03:35 +00:00
parent 5f5b0e131b
commit 20ef12db55
12 changed files with 176 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
TODO.FACTOR.txt
View File

@ -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

23
library/compiler/assembly-x86.factor
View File

@ -113,7 +113,7 @@ USE: combinators
: [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>.
@ -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.

26
library/compiler/compiler-macros.factor
View File

@ -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]

4
library/compiler/ifte.factor
View File

@ -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.

1
library/platform/native/boot-stage2.factor
View File

@ -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"

2
library/platform/native/stack.factor
View File

@ -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

26
library/test/inference.factor
View File

@ -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

108
library/tools/inference.factor
View File

@ -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 <vector> 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

4
native/gc.c
View File

@ -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++)

16
native/run.h
View File

@ -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)

36
native/stack.c
View File

@ -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)

4
native/stack.h
View File

@ -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);