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

compiling mutually recursive words

cvs
Slava Pestov 2004-09-28 04:24:36 +00:00
parent 2c2d33d6e9
commit 564a8ad46c
27 changed files with 275 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
TODO.FACTOR.txt
View File

@ -1,6 +1,8 @@
FFI:
- is signed -vs- unsigned pointers an issue?
- symbols are not primitives
[error] SideKick$BufferChangeHandler: We have cplusplus.xml (/home/slava/jEdit/modes/) but got event for DefaultInputHandler.java (/home/slava/jEdit/org/gjt/sp/jedit/gui/)
[error] SideKick$BufferChangeHandler: We have cplusplus.xml (/home/slava/jEdit/modes/) but got event for DefaultInputHandler.java (/home/slava/jEdit/org/gjt/sp/jedit/gui/)

56
doc/alien.txt Normal file
View File

@ -0,0 +1,56 @@
SOME NOTES ON FACTOR'S FFI
The FFI is quite a neat design and I think it is better than JNI and
similar approaches. Also, it offers better performance than libffi et
al. Of course, both of those technologies are great and Factor FFI has
its drawbacks -- namely, its not portable.
All FFI words are in the "alien" vocabulary.
The basic principle is generating machine stubs from C function
prototypes. The main entry point is the 'alien-call' word, which is
defined as simply throwing an error. However, it is given special
compilation behavior. This means it can only be used in compiled words.
Here is an example from sdl-video.factor:
: SDL_LockSurface ( surface -- )
"int" "sdl" "SDL_LockSurface" [ "surface*" ] alien-call ; compiled
The parameters are:
"int" - return type. later it will be surface*
"sdl" - library
"SDL_LockSurface" - function
[ "surface*" ] - parameters
Note the word ends with 'compiled'. This is a hack and won't be needed
later.
Parameters and return values are C type names. C types include the
following:
- char - 1 byte signed
- short - 2 bytes signed
- int - 4 bytes signed
- void* - word-size width field, can only be used as a parameter
Structs can be defined in this fashion:
BEGIN-STRUCT: point
FIELD: int x
FIELD: int y
END-STRUCT
And then referred to in parameter type specifiers as "point*". Struct
return values are not yet supported.
Enumerations can be defined; they simply become words that push
integers:
BEGIN-ENUM: 0
ENUM: int xuzzy
ENUM: int bax
END-ENUM
The parameter to BEGIN-ENUM specifies the starting index.

4
library/compiler/alien-macros.factor
View File

@ -36,14 +36,14 @@ USE: stack
: UNBOX ( name -- )
#! Move top of datastack to C stack.
dlsym-self CALL drop
dlsym-self CALL JUMP-FIXUP
EAX PUSH-R ;
: BOX ( name -- )
#! Move EAX to datastack.
24 ESP R-I
EAX PUSH-R
dlsym-self CALL drop
dlsym-self CALL JUMP-FIXUP
28 ESP R+I ;
: PARAMETERS ( params -- count )

6
library/compiler/alien.factor
View File

@ -36,7 +36,7 @@ USE: stack
USE: words
: BEGIN-ENUM:
#! C-style enumartions. Their use is not encouraged unless
#! C-style enumerations. Their use is not encouraged unless
#! it is for C library interfaces. Used like this:
#!
#! BEGIN-ENUM 0
@ -69,11 +69,11 @@ USE: words
: compile-alien-call
pop-literal reverse PARAMETERS >r
pop-literal pop-literal alien-function CALL drop
pop-literal pop-literal alien-function CALL JUMP-FIXUP
r> CLEANUP
pop-literal RETURNS ;
global [ <namespace> "libraries" set ] bind
[ alien-call compile-alien-call ]
unswons "compiling" swap set-word-property
unswons "compiling" set-word-property

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

@ -147,24 +147,24 @@ USE: combinators
compile-cell
] ifte ;
: fixup ( addr where -- )
: JUMP-FIXUP ( addr where -- )
#! Encode a relative offset to addr from where at where.
#! Add 4 because addr is relative to *after* insn.
dup >r 4 + - r> set-compiled-cell ;
: (JUMP) ( xt -- fixup )
#! addr is relative to *after* insn
compiled-offset dup >r 4 + - compile-cell r> ;
compiled-offset 0 compile-cell ;
: JUMP ( xt -- fixup )
: JUMP ( -- fixup )
#! Push address of branch for fixup
HEX: e9 compile-byte (JUMP) ;
: CALL ( xt -- fixup )
: CALL ( -- fixup )
HEX: e8 compile-byte (JUMP) ;
: JE ( xt -- fixup )
HEX: 0f compile-byte HEX: 84 compile-byte (JUMP) ;
: JE ( -- fixup )
HEX: 0f compile-byte HEX: 84 compile-byte (JUMP) ;
: RET ( -- )
HEX: c3 compile-byte ;

119
library/compiler/compiler.factor
View File

@ -28,6 +28,7 @@
IN: compiler
USE: combinators
USE: errors
USE: hashtables
USE: kernel
USE: lists
USE: logic
@ -40,8 +41,69 @@ USE: unparser
USE: vectors
USE: words
! We use a hashtable "compiled-xts" that maps words to
! xt's that are currently being compiled. The commit-xt's word
! sets the xt of each word in the hashtable to the value in the
! hastable.
!
! This has the advantage that we can compile a word before the
! words it depends on and perform a fixup later; among other
! things this enables mutually recursive words.
SYMBOL: compiled-xts
: save-xt ( word -- )
cell compile-aligned
compiled-offset swap compiled-xts acons@ ;
: commit-xts ( -- )
compiled-xts get [ unswons set-word-xt ] each
compiled-xts off ;
: compiled-xt ( word -- xt )
dup compiled-xts get assoc dup [
nip
] [
drop word-xt
] ifte ;
! "fixup-xts" is a list of [ where | word ] pairs; the xt of
! word when its done compiling will be written to the offset.
SYMBOL: deferred-xts
: defer-xt ( word where -- )
#! After word is compiled, put a call to it at offset.
deferred-xts acons@ ;
: fixup-deferred-xt ( where word -- )
compiled-xt swap JUMP-FIXUP ;
: fixup-deferred-xts ( -- )
deferred-xts get [ uncons fixup-deferred-xt ] each
deferred-xts off ;
! Words being compiled are consed onto this list. When a word
! is encountered that has not been previously compiled, it is
! consed onto this list. Compilation stops when the list is
! empty.
SYMBOL: compile-words
: postpone-word ( word -- )
t over "compiled" set-word-property
compile-words cons@ ;
! During compilation, these two variables store pending
! literals. Literals are either consumed at compile-time by
! words with special compilation behavior, or otherwise they are
! compiled into code that pushes them.
SYMBOL: compile-datastack
SYMBOL: compile-callstack
: pop-literal ( -- obj )
"compile-datastack" get vector-pop ;
compile-datastack get vector-pop ;
: immediate? ( obj -- ? )
#! fixnums and f have a pointerless representation, and
@ -57,7 +119,7 @@ USE: words
] ifte ;
: commit-literals ( -- )
"compile-datastack" get
compile-datastack get
dup vector-empty? [
drop
] [
@ -65,46 +127,43 @@ USE: words
0 swap set-vector-length
] ifte ;
: postpone ( obj -- )
: postpone-literal ( obj -- )
#! Literals are not compiled immediately, so that words like
#! ifte with special compilation behavior can work.
"compile-datastack" get vector-push ;
compile-datastack get vector-push ;
: tail? ( -- ? )
"compile-callstack" get vector-empty? ;
compile-callstack get vector-empty? ;
: compiled-xt ( word -- xt )
"compiled-xt" over word-property dup [
nip
] [
drop word-xt
] ifte ;
: compiled? ( word -- ? )
#! This is a hack.
dup "compiled" word-property swap primitive? or ;
: compile-simple-word ( word -- )
#! Compile a JMP at the end (tail call optimization)
commit-literals compiled-xt
tail? [ JUMP ] [ CALL ] ifte drop ;
dup compiled? [ dup postpone-word ] unless
commit-literals tail? [ JUMP ] [ CALL ] ifte defer-xt ;
: compile-word ( word -- )
#! If a word has a compiling property, then it has special
#! compilation behavior.
"compiling" over word-property dup [
dup "compiling" word-property dup [
nip call
] [
drop compile-simple-word
] ifte ;
: begin-compiling-quot ( quot -- )
"compile-callstack" get vector-push ;
compile-callstack get vector-push ;
: end-compiling-quot ( -- )
"compile-callstack" get vector-pop drop ;
compile-callstack get vector-pop drop ;
: compiling ( quot -- )
#! Called on each iteration of compile-loop, with the
#! remaining quotation.
[
"compile-callstack" get
compile-callstack get
dup vector-length pred
swap set-vector-nth
] [
@ -112,7 +171,7 @@ USE: words
] ifte* ;
: compile-atom ( obj -- )
dup word? [ compile-word ] [ postpone ] ifte ;
dup word? [ compile-word ] [ postpone-literal ] ifte ;
: compile-loop ( quot -- )
[
@ -126,23 +185,23 @@ USE: words
: with-compiler ( quot -- )
[
10 <vector> "compile-datastack" set
10 <vector> "compile-callstack" set
10 <vector> compile-datastack set
10 <vector> compile-callstack set
call
fixup-deferred-xts
commit-xts
] with-scope ;
: begin-compiling ( word -- )
cell compile-aligned
compiled-offset "compiled-xt" rot set-word-property ;
: (compile) ( word -- )
#! Should be called inside the with-compiler scope.
intern dup save-xt word-parameter compile-quot RET ;
: end-compiling ( word -- xt )
"compiled-xt" over word-property over set-word-xt
f "compiled-xt" rot set-word-property ;
: compile-postponed ( -- )
compile-words get [
uncons compile-words set (compile) compile-postponed
] when* ;
: compile ( word -- )
intern dup
begin-compiling
dup word-parameter [ compile-quot RET ] with-compiler
end-compiling ;
[ postpone-word compile-postponed ] with-compiler ;
: compiled word compile ; parsing

9
library/compiler/words.factor
View File

@ -38,16 +38,17 @@ USE: lists
POP-DS
! ptr to condition is now in EAX
f address EAX CMP-I-[R]
compiled-offset JE ;
! jump w/ address added later
JE ;
: branch-target ( fixup -- )
cell compile-aligned compiled-offset swap fixup ;
cell compile-aligned compiled-offset swap JUMP-FIXUP ;
: compile-else ( fixup -- fixup )
#! Push addr where we write the branch target address,
#! and fixup branch target address from compile-f-test.
#! Push f for the fixup if we're tail position.
tail? [ RET f ] [ 0 JUMP ] ifte swap branch-target ;
tail? [ RET f ] [ JUMP ] ifte swap branch-target ;
: compile-end-if ( fixup -- )
tail? [ drop RET ] [ branch-target ] ifte ;
@ -63,5 +64,5 @@ USE: lists
[
[ ifte compile-ifte ]
] [
unswons "compiling" swap set-word-property
unswons "compiling" set-word-property
] each

2
library/cross-compiler.factor
View File

@ -190,7 +190,7 @@ DEFER: unparse-float
IN: image
: primitives, ( -- )
1 [
2 [
execute
call
ifte

4
library/jedit/jedit.factor
View File

@ -63,8 +63,8 @@ USE: words
: word-line/file ( word -- line dir file )
#! Note that line numbers here start from 1
"line" over word-property swap
"file" swap word-property word-file ;
dup "line" word-property swap "file" word-property
word-file ;
: jedit ( word -- )
intern dup [

9
library/list-namespaces.factor
View File

@ -46,6 +46,15 @@ USE: stack
#! Prepend x to the list stored in var.
tuck get cons put ;
: acons@ ( value key var -- )
#! Prepend [ key | value ] to the alist stored in var.
[ get acons ] keep set ;
: uncons@ ( var -- car )
#! Push the car of the list in var, and set the var to the
#! cdr.
dup get uncons rot set ;
: remove@ ( obj var -- )
#! Remove all occurrences of the object from the list
#! stored in the variable.

6
library/lists.factor
View File

@ -374,7 +374,11 @@ DEFER: tree-contains?
: cdr= swap cdr swap cdr = ;
: cons= ( obj cons -- ? )
over cons? [ 2dup car= >r cdr= r> and ] [ 2drop f ] ifte ;
2dup eq? [
2drop t
] [
over cons? [ 2dup car= >r cdr= r> and ] [ 2drop f ] ifte
] ifte ;
: cons-hashcode ( cons count -- hash )
dup 0 = [

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

@ -26,14 +26,16 @@
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: init
USE: combinators
USE: errors
USE: kernel
USE: lists
USE: parser
USE: stack
USE: strings
USE: stdio
"Cold boot in progress..." print
[
"/library/platform/native/kernel.factor"
"/library/platform/native/stack.factor"

19
library/platform/native/parse-syntax.factor
View File

@ -68,13 +68,13 @@ USE: unparser
! Colon defs
: CREATE ( -- word )
scan "in" get create dup set-word
f "documentation" pick set-word-property
f "stack-effect" pick set-word-property ;
f over "documentation" set-word-property
f over "stack-effect" set-word-property ;
: remember-where ( word -- )
"line-number" get "line" pick set-word-property
"col" get "col" pick set-word-property
"file" get "file" pick set-word-property
"line-number" get over "line" set-word-property
"col" get over "col" set-word-property
"file" get over "file" set-word-property
drop ;
: :
@ -91,6 +91,9 @@ USE: unparser
nreverse
;-hook ; parsing
! Symbols
: SYMBOL: CREATE define-symbol ; parsing
! Vocabularies
: DEFER: CREATE drop ; parsing
: USE: scan "use" cons@ ; parsing
@ -157,7 +160,7 @@ USE: unparser
: parsed-stack-effect ( parsed str -- parsed )
over doc-comment-here? [
"stack-effect" word set-word-property
word "stack-effect" set-word-property
] [
drop
] ifte ;
@ -168,11 +171,11 @@ USE: unparser
: documentation+ ( str word -- )
[
"documentation" swap word-property [
"documentation" word-property [
swap "\n" swap cat3
] when*
] keep
"documentation" swap set-word-property ;
"documentation" set-word-property ;
: parsed-documentation ( parsed str -- parsed )
over doc-comment-here? [

6
library/platform/native/parser.factor
View File

@ -50,7 +50,7 @@ USE: unparser
: parsing? ( word -- ? )
dup word? [
"parsing" swap word-property
"parsing" word-property
] [
drop f
] ifte ;
@ -59,7 +59,7 @@ USE: unparser
#! Mark the most recently defined word to execute at parse
#! time, rather than run time. The word can use 'scan' to
#! read ahead in the input stream.
t "parsing" word set-word-property ;
t word "parsing" set-word-property ;
: end? ( -- ? )
"col" get "line" get str-length >= ;
@ -185,4 +185,4 @@ USE: unparser
! Once this file has loaded, we can use 'parsing' normally.
! This hack is needed because in Java Factor, 'parsing' is
! not parsing, but in CFactor, it is.
t "parsing" "parsing" [ "parser" ] search set-word-property
t "parsing" [ "parser" ] search "parsing" set-word-property

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

@ -236,5 +236,5 @@ USE: words
[ set-alien-1 | " n alien off -- " ]
[ heap-stats | " -- instances bytes " ]
] [
unswons "stack-effect" swap set-word-property
unswons "stack-effect" set-word-property
] each

14
library/platform/native/vectors.factor
View File

@ -57,14 +57,18 @@ USE: stack
#! Check if two vectors are equal. Two vectors are
#! considered equal if they have the same length and contain
#! equal elements.
over vector? [
2dup vector-length= [
0 -rot (vector=)
2dup eq? [
2drop t
] [
over vector? [
2dup vector-length= [
0 -rot (vector=)
] [
2drop f
] ifte
] [
2drop f
] ifte
] [
2drop f
] ifte ;
: ?vector-nth ( n vec -- obj/f )

19
library/platform/native/words.factor
View File

@ -33,11 +33,11 @@ USE: logic
USE: namespaces
USE: stack
: word-property ( pname word -- pvalue )
word-plist assoc ;
: word-property ( word pname -- pvalue )
swap word-plist assoc ;
: set-word-property ( pvalue pname word -- )
dup >r word-plist set-assoc r> set-word-plist ;
: set-word-property ( pvalue word pname -- )
swap [ word-plist set-assoc ] keep set-word-plist ;
: defined? ( obj -- ? )
dup word? [ word-primitive 0 = not ] [ drop f ] ifte ;
@ -48,6 +48,9 @@ USE: stack
: primitive? ( obj -- ? )
dup word? [ word-primitive 1 = not ] [ drop f ] ifte ;
: symbol? ( obj -- ? )
dup word? [ word-primitive 2 = ] [ drop f ] ifte ;
! Various features not supported by native Factor.
: comment? drop f ;
@ -61,8 +64,12 @@ USE: stack
over set-word-parameter
1 swap set-word-primitive ;
: define-symbol ( word -- )
dup dup set-word-parameter
2 swap set-word-primitive ;
: stack-effect ( word -- str )
"stack-effect" swap word-property ;
"stack-effect" word-property ;
: documentation ( word -- str )
"documentation" swap word-property ;
"documentation" word-property ;

5
library/prettyprint.factor
View File

@ -199,9 +199,8 @@ DEFER: prettyprint*
tab-size - ;
: prettyprint-plist ( word -- )
"parsing" over word-property [ " parsing" write ] when
"inline" over word-property [ " inline" write ] when
drop ;
dup "parsing" word-property [ " parsing" write ] when
"inline" word-property [ " inline" write ] when ;
: . ( obj -- )
[

14
library/test/jvm-compiler/miscellaneous.factor
View File

@ -40,11 +40,6 @@ USE: words
[ t ] [ ] [ word-parameter-test ] test-word
: words-test ( -- ? )
t vocabs [ words [ word? and ] each ] each ;
[ t ] [ ] [ words-test ] test-word
! At one time we had a bug in FactorShuffleDefinition.toList()
~<< test-shuffle-1 A r:B -- A r:B >>~
@ -95,15 +90,6 @@ test-word
[ [ 1 1 0 0 ] ] [ [ system-property ] ] [ balance>list ] test-word
: test-last ( -- )
nop ;
word >str "last-word-test" set
[ "test-last" ] [ ] [ "last-word-test" get ] test-word
[ f ] [ 5 ] [ compound? ] test-word
[ f ] [ 5 ] [ compiled? ] test-word
[ f ] [ 5 ] [ shuffle? ] test-word
! Make sure callstack only clones callframes, and not
! everything on the callstack.
[ ] [ ] [ f unit dup dup set-cdr >r callstack r> 2drop ] test-word

7
library/test/lists/namespaces.factor
View File

@ -8,3 +8,10 @@ USE: test
[ [ 1 ] ] [ 1 f ] [ "x" set "x" cons@ "x" get ] test-word
[ [ 1 | 2 ] ] [ 1 2 ] [ "x" set "x" cons@ "x" get ] test-word
[ [ 1 2 ] ] [ 1 [ 2 ] ] [ "x" set "x" cons@ "x" get ] test-word
[ [ [ 2 | 3 ] [ 1 | 2 ] ] ] [
"x" off 2 1 "x" acons@ 3 2 "x" acons@ "x" get
] unit-test
[ [ 2 | 3 ] ] [ "x" uncons@ ] unit-test
[ [ 1 | 2 ] ] [ "x" uncons@ ] unit-test

15
library/test/words.factor
View File

@ -2,8 +2,23 @@ IN: scratchpad
USE: math
USE: test
USE: words
USE: namespaces
USE: logic
USE: lists
[ 4 ] [
"poo" "scratchpad" create [ 2 2 + ] define-compound
"poo" [ "scratchpad" ] search execute
] unit-test
: words-test ( -- ? )
t vocabs [ words [ word? and ] each ] each ;
[ t ] [ ] [ words-test ] test-word
: test-last ( -- ) ;
word word-name "last-word-test" set
[ "test-last" ] [ ] [ "last-word-test" get ] test-word
[ f ] [ 5 ] [ compound? ] test-word

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

@ -7,23 +7,29 @@ USE: kernel
USE: combinators
USE: words
"Hi." USE: stdio print
: no-op ; compiled
[ ] [ no-op ] unit-test
: literals 3 5 ; compiled
: tail-call fixnum+ ; compiled
[ 4 ] [ 1 3 tail-call ] unit-test
[ 3 5 ] [ literals ] unit-test
: literals&tail-call 3 5 + ; compiled
: literals&tail-call 3 5 fixnum+ ; compiled
[ 8 ] [ literals&tail-call ] unit-test
: two-calls dup * ; compiled
: two-calls dup fixnum* ; compiled
[ 25 ] [ 5 two-calls ] unit-test
: mix-test 3 5 + 6 * ; compiled
: mix-test 3 5 fixnum+ 6 fixnum* ; compiled
[ 48 ] [ mix-test ] unit-test
@ -50,7 +56,7 @@ garbage-collection
[ 2 ] [ dummy-ifte-4 ] unit-test
: dummy-ifte-5 0 dup 1 <= [ drop 1 ] [ ] ifte ; compiled
: dummy-ifte-5 0 dup 1 fixnum<= [ drop 1 ] [ ] ifte ; compiled
[ 1 ] [ dummy-ifte-5 ] unit-test
@ -58,7 +64,7 @@ garbage-collection
dup 1 <= [
drop 1
] [
1 - dup swap 1 - +
1 fixnum- dup swap 1 fixnum- fixnum+
] ifte ;
[ 17 ] [ 10 dummy-ifte-6 ] unit-test
@ -80,3 +86,10 @@ garbage-collection
t [ ] [ ] ifte 5 ; compiled
[ 5 ] [ after-ifte-test ] unit-test
DEFER: countdown-b
: countdown-a ( n -- ) dup 0 eq? [ drop ] [ pred countdown-b ] ifte ;
: countdown-b ( n -- ) dup 0 eq? [ drop ] [ pred countdown-a ] ifte ; compiled
[ ] [ 10 countdown-b ] unit-test

8
library/words.factor
View File

@ -34,16 +34,16 @@ USE: namespaces
USE: stack
: word-name ( word -- name )
"name" swap word-property ;
"name" word-property ;
: set-word-name ( word name -- )
"name" swap set-word-property ;
"name" set-word-property ;
: word-vocabulary ( word -- vocab )
"vocabulary" swap word-property ;
"vocabulary" word-property ;
: set-word-vocabulary ( word vocab -- )
"vocabulary" swap set-word-property ;
"vocabulary" set-word-property ;
: each-word ( quot -- )
#! Apply a quotation to each word in the image.

1
native/primitives.c
View File

@ -3,6 +3,7 @@
XT primitives[] = {
undefined,
docol,
dosym,
primitive_execute,
primitive_call,
primitive_ifte,

2
native/primitives.h
View File

@ -1,4 +1,4 @@
extern XT primitives[];
#define PRIMITIVE_COUNT 193
#define PRIMITIVE_COUNT 194
CELL primitive_to_xt(CELL primitive);

6
native/run.c
View File

@ -91,6 +91,12 @@ void docol(void)
call(executing->parameter);
}
/* pushes word parameter */
void dosym(void)
{
dpush(executing->parameter);
}
void primitive_execute(void)
{
executing = untag_word(dpop());

1
native/run.h
View File

@ -103,6 +103,7 @@ void clear_environment(void);
void run(void);
void undefined(void);
void docol(void);
void dosym(void);
void primitive_execute(void);
void primitive_call(void);
void primitive_ifte(void);