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

'generic' word now compiled

cvs
Slava Pestov 2004-10-02 02:02:54 +00:00
parent c6013cd941
commit 1c2dbb1888
11 changed files with 320 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -61,10 +61,14 @@ USE: alien
4 DATASTACK I+[I] 4 DATASTACK I+[I]
ECX POP-R ; ECX POP-R ;
: PEEK-DS ( -- )
#! Peek datastack, store pointer to datastack top in EAX.
DATASTACK EAX [I]>R
4 EAX R-I ;
: POP-DS ( -- ) : POP-DS ( -- )
#! Pop datastack, store pointer to datastack top in EAX. #! Pop datastack, store pointer to datastack top in EAX.
DATASTACK EAX [I]>R PEEK-DS
4 EAX R-I
EAX DATASTACK R>[I] ; EAX DATASTACK R>[I] ;
: SELF-CALL ( name -- ) : SELF-CALL ( name -- )
@ -72,8 +76,8 @@ USE: alien
dlsym-self CALL JUMP-FIXUP ; dlsym-self CALL JUMP-FIXUP ;
: TYPE-OF ( -- ) : TYPE-OF ( -- )
#! Pop datastack, store type # in EAX. #! Peek datastack, store type # in EAX.
POP-DS PEEK-DS
EAX PUSH-[R] EAX PUSH-[R]
"type_of" SELF-CALL "type_of" SELF-CALL
4 ESI R-I ; 4 ESP R+I ;

44
library/compiler/compiler.factor
View File

@ -35,6 +35,7 @@ USE: logic
USE: math USE: math
USE: namespaces USE: namespaces
USE: parser USE: parser
USE: prettyprint
USE: stack USE: stack
USE: strings USE: strings
USE: unparser USE: unparser
@ -67,20 +68,31 @@ SYMBOL: compiled-xts
drop word-xt drop word-xt
] ifte ; ] ifte ;
! "fixup-xts" is a list of [ where | word ] pairs; the xt of ! "fixup-xts" is a list of [ where word relative ] pairs; the xt
! word when its done compiling will be written to the offset. ! of word when its done compiling will be written to the offset,
! relative to the offset.
SYMBOL: deferred-xts SYMBOL: deferred-xts
: defer-xt ( word where -- ) : defer-xt ( word where relative -- )
#! After word is compiled, put a call to it at offset. #! After word is compiled, put its XT at where, relative.
deferred-xts acons@ ; 3list deferred-xts cons@ ;
: fixup-deferred-xt ( where word -- ) : compiled? ( word -- ? )
compiled-xt swap JUMP-FIXUP ; #! This is a hack.
dup "compiled" word-property swap primitive? or ;
: fixup-deferred-xt ( word where relative -- )
rot dup compiled? [
compiled-xt swap - swap set-compiled-cell
] [
"Not compiled: " swap word-name cat2 throw
] ifte ;
: fixup-deferred-xts ( -- ) : fixup-deferred-xts ( -- )
deferred-xts get [ uncons fixup-deferred-xt ] each deferred-xts get [
uncons uncons car fixup-deferred-xt
] each
deferred-xts off ; deferred-xts off ;
! Words being compiled are consed onto this list. When a word ! Words being compiled are consed onto this list. When a word
@ -91,8 +103,11 @@ SYMBOL: deferred-xts
SYMBOL: compile-words SYMBOL: compile-words
: postpone-word ( word -- ) : postpone-word ( word -- )
t over "compiled" set-word-property dup compiled? [
compile-words cons@ ; drop
] [
t over "compiled" set-word-property compile-words cons@
] ifte ;
! During compilation, these two variables store pending ! During compilation, these two variables store pending
! literals. Literals are either consumed at compile-time by ! literals. Literals are either consumed at compile-time by
@ -135,14 +150,11 @@ SYMBOL: compile-callstack
: tail? ( -- ? ) : tail? ( -- ? )
compile-callstack get vector-empty? ; compile-callstack get vector-empty? ;
: compiled? ( word -- ? )
#! This is a hack.
dup "compiled" word-property swap primitive? or ;
: compile-simple-word ( word -- ) : compile-simple-word ( word -- )
#! Compile a JMP at the end (tail call optimization) #! Compile a JMP at the end (tail call optimization)
dup compiled? [ dup postpone-word ] unless dup postpone-word
commit-literals tail? [ JUMP ] [ CALL ] ifte defer-xt ; commit-literals tail? [ JUMP ] [ CALL ] ifte
compiled-offset defer-xt ;
: compile-word ( word -- ) : compile-word ( word -- )
#! If a word has a compiling property, then it has special #! If a word has a compiling property, then it has special

69
library/compiler/words.factor → library/compiler/generic.factor
View File

@ -32,72 +32,53 @@ USE: stack
USE: kernel USE: kernel
USE: math USE: math
USE: lists USE: lists
USE: vectors
: F-TEST ( -- fixup ) : compile-table-jump ( start-fixup -- end-fixup )
#! Push addr where we write the branch target address.
POP-DS
! ptr to condition is now in EAX
f address EAX CMP-I-[R]
! jump w/ address added later
JE ;
: branch-target ( fixup -- )
compiled-offset swap JUMP-FIXUP ;
: 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 ] [ JUMP ] ifte swap branch-target ;
: END-IF ( fixup -- )
tail? [ drop RET ] [ branch-target ] ifte ;
: compile-ifte ( compile-time: true false -- )
pop-literal pop-literal commit-literals
F-TEST >r
( t -- ) compile-quot
r> ELSE >r
( f -- ) compile-quot
r> END-IF ;
: TABLE-JUMP ( start-fixup -- end-fixup )
#! The 32-bit address of the code after the jump table #! The 32-bit address of the code after the jump table
#! should be written to end-fixup. #! should be written to end-fixup.
#! The jump table must immediately follow this macro. #! The jump table must immediately follow this macro.
tail? [ 0 ] [ 0 PUSH-I compiled-offset 4 - ] ifte >r tail? [ 0 ] [ 0 PUSH-I compiled-offset 4 - ] ifte >r
( start-fixup r:end-fixup ) ( start-fixup r:end-fixup )
EAX JUMP-[R] EAX JUMP-[R]
cell compile-aligned
compiled-offset swap set-compiled-cell ( update the ADD ) compiled-offset swap set-compiled-cell ( update the ADD )
r> ; r> ;
: BEGIN-JUMP-TABLE ( -- end-fixup ) : begin-jump-table ( -- end-fixup )
#! Compile a piece of code that jumps to an offset in a #! Compile a piece of code that jumps to an offset in a
#! jump table indexed by the type of the Factor object in #! jump table indexed by the type of the Factor object in
#! EAX. #! EAX.
TYPE-OF TYPE-OF
2 EAX R<<I 2 EAX R<<I
EAX+/PARTIAL EAX+/PARTIAL
TABLE-JUMP ; compile-table-jump ;
: END-JUMP-TABLE ( end-fixup -- ) : jump-table-entry ( word -- )
compiled-offset dup 0 = [ #! Jump table entries are absolute addresses.
2drop dup postpone-word
compiled-offset 0 compile-cell 0 fixup-deferred-xt ;
: compile-jump-table ( vtable -- )
#! Compile a table of words as a word-array of XTs.
num-types [
over ?vector-nth jump-table-entry
] times* drop ;
: end-jump-table ( end-fixup -- )
#! update the PUSH.
dup 0 = [
drop
] [ ] [
set-compiled-cell ( update the PUSH ) compiled-offset swap set-compiled-cell
] ifte ; ] ifte ;
: compile-generic ( compile-time: vtable -- ) : compile-generic ( compile-time: vtable -- )
#! Compile a faster alternative to #! Compile a faster alternative to
#! : generic ( obj vtable -- ) #! : generic ( obj vtable -- )
#! >r dup type r> vector-nth execute ; #! >r dup type r> vector-nth execute ;
BEGIN-JUMP-TABLE begin-jump-table
! write table now pop-literal compile-jump-table
END-JUMP-TABLE ; end-jump-table ;
[ [ compile-generic ] \ generic "compiling" set-word-property
[ ifte compile-ifte ]
[ generic compile-generic ]
] [
unswons "compiling" set-word-property
] each

64
library/compiler/ifte.factor Normal file
View File

@ -0,0 +1,64 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: compiler
USE: combinators
USE: words
USE: stack
USE: kernel
USE: math
USE: lists
: compile-f-test ( -- fixup )
#! Push addr where we write the branch target address.
POP-DS
! ptr to condition is now in EAX
f address EAX CMP-I-[R]
! jump w/ address added later
JE ;
: branch-target ( fixup -- )
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 ] [ JUMP ] ifte swap branch-target ;
: end-if ( fixup -- )
tail? [ drop RET ] [ branch-target ] ifte ;
: compile-ifte ( compile-time: true false -- )
pop-literal pop-literal commit-literals
compile-f-test >r
( t -- ) compile-quot
r> compile-else >r
( f -- ) compile-quot
r> end-if ;
[ compile-ifte ] \ ifte "compiling" set-word-property

50
library/compiler/interpret-only.factor Normal file
View File

@ -0,0 +1,50 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: compiler
USE: combinators
USE: errors
USE: kernel
USE: lists
USE: stack
USE: strings
USE: words
: interpret-only-error ( name -- )
"Cannot compile " swap cat2 throw ;
: word-interpret-only ( word -- )
dup word-name [ interpret-only-error ] cons
swap
"compiling" set-word-property ;
\ call word-interpret-only
\ datastack word-interpret-only
\ callstack word-interpret-only
\ set-datastack word-interpret-only
\ set-callstack word-interpret-only
\ 2generic word-interpret-only

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

@ -139,7 +139,9 @@ USE: stdio
"/library/compiler/assembly-x86.factor" "/library/compiler/assembly-x86.factor"
"/library/compiler/compiler-macros.factor" "/library/compiler/compiler-macros.factor"
"/library/compiler/compiler.factor" "/library/compiler/compiler.factor"
"/library/compiler/words.factor" "/library/compiler/ifte.factor"
"/library/compiler/generic.factor"
"/library/compiler/interpret-only.factor"
"/library/compiler/alien-types.factor" "/library/compiler/alien-types.factor"
"/library/compiler/alien-macros.factor" "/library/compiler/alien-macros.factor"
"/library/compiler/alien.factor" "/library/compiler/alien.factor"

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

@ -94,6 +94,11 @@ USE: unparser
! Symbols ! Symbols
: SYMBOL: CREATE define-symbol ; parsing : SYMBOL: CREATE define-symbol ; parsing
: \
#! Parsed as a piece of code that pushes a word on the stack
#! \ foo ==> [ foo ] car
scan-word unit parsed [ car ] car parsed ; parsing
! Vocabularies ! Vocabularies
: DEFER: CREATE drop ; parsing : DEFER: CREATE drop ; parsing
: USE: scan "use" cons@ ; parsing : USE: scan "use" cons@ ; parsing

4
library/platform/native/types.factor
View File

@ -70,3 +70,7 @@ IN: kernel
[ 103 | "fixnum/bignum/ratio/float/complex" ] [ 103 | "fixnum/bignum/ratio/float/complex" ]
[ 104 | "fixnum/string" ] [ 104 | "fixnum/string" ]
] assoc ; ] assoc ;
: num-types ( -- n )
#! One more than the maximum value from type-of.
17 ;

91
library/test/x86-compiler/generic.factor Normal file
View File

@ -0,0 +1,91 @@
IN: scratchpad
USE: compiler
USE: test
USE: math
USE: stack
USE: kernel
USE: logic
USE: combinators
USE: words
: generic-test ( obj -- hash )
{
drop
drop
drop
drop
drop
drop
nip
drop
drop
drop
drop
drop
drop
drop
drop
drop
drop
} generic ; compiled
[ 2 3 ] [ 2 3 t generic-test ] unit-test
[ 2 3 ] [ 2 3 4 generic-test ] unit-test
[ 2 f ] [ 2 3 f generic-test ] unit-test
: generic-test-alt ( obj -- hash )
{
drop
drop
drop
drop
nip
drop
drop
drop
drop
drop
drop
drop
drop
drop
drop
drop
drop
} generic fixnum+ ; compiled
[ 5 ] [ 2 3 4 generic-test-alt ] unit-test
[ 3 ] [ 2 3 3/2 generic-test-alt ] unit-test
DEFER: generic-test-2
: generic-test-4
not generic-test-2 ;
: generic-test-3
drop 3 ;
: generic-test-2
{
generic-test-3
generic-test-3
generic-test-3
generic-test-3
generic-test-3
generic-test-3
generic-test-4
generic-test-3
generic-test-3
generic-test-3
generic-test-3
generic-test-3
generic-test-3
generic-test-3
generic-test-3
generic-test-3
generic-test-3
} generic ;
[ 3 ] [ t generic-test-2 ] unit-test
[ 3 ] [ 3 generic-test-2 ] unit-test
[ 3 ] [ f generic-test-2 ] unit-test

32
library/test/x86-compiler/compiler.factor → library/test/x86-compiler/ifte.factor
View File

@ -4,40 +4,10 @@ USE: test
USE: math USE: math
USE: stack USE: stack
USE: kernel USE: kernel
USE: logic
USE: combinators USE: combinators
USE: words USE: words
: 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 fixnum+ ; compiled
[ 8 ] [ literals&tail-call ] unit-test
: two-calls dup fixnum* ; compiled
[ 25 ] [ 5 two-calls ] unit-test
: mix-test 3 5 fixnum+ 6 fixnum* ; compiled
[ 48 ] [ mix-test ] unit-test
: indexed-literal-test "hello world" ; compiled
garbage-collection
garbage-collection
[ "hello world" ] [ indexed-literal-test ] unit-test
: dummy-ifte-1 t [ ] [ ] ifte ; compiled : dummy-ifte-1 t [ ] [ ] ifte ; compiled
[ ] [ dummy-ifte-1 ] unit-test [ ] [ dummy-ifte-1 ] unit-test

40
library/test/x86-compiler/simple.factor Normal file
View File

@ -0,0 +1,40 @@
IN: scratchpad
USE: compiler
USE: test
USE: math
USE: stack
USE: kernel
USE: logic
USE: combinators
USE: words
: 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 fixnum+ ; compiled
[ 8 ] [ literals&tail-call ] unit-test
: two-calls dup fixnum* ; compiled
[ 25 ] [ 5 two-calls ] unit-test
: mix-test 3 5 fixnum+ 6 fixnum* ; compiled
[ 48 ] [ mix-test ] unit-test
: indexed-literal-test "hello world" ; compiled
garbage-collection
garbage-collection
[ "hello world" ] [ indexed-literal-test ] unit-test