From 1c2dbb18887364a9e5f18bfc7b56990b41ad4ded Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 2 Oct 2004 02:02:54 +0000 Subject: [PATCH] 'generic' word now compiled --- library/compiler/compiler-macros.factor | 14 ++- library/compiler/compiler.factor | 44 +++++---- .../compiler/{words.factor => generic.factor} | 69 +++++--------- library/compiler/ifte.factor | 64 +++++++++++++ library/compiler/interpret-only.factor | 50 ++++++++++ library/platform/native/boot-stage2.factor | 4 +- library/platform/native/parse-syntax.factor | 5 + library/platform/native/types.factor | 4 + library/test/x86-compiler/generic.factor | 91 +++++++++++++++++++ .../{compiler.factor => ifte.factor} | 32 +------ library/test/x86-compiler/simple.factor | 40 ++++++++ 11 files changed, 320 insertions(+), 97 deletions(-) rename library/compiler/{words.factor => generic.factor} (64%) create mode 100644 library/compiler/ifte.factor create mode 100644 library/compiler/interpret-only.factor create mode 100644 library/test/x86-compiler/generic.factor rename library/test/x86-compiler/{compiler.factor => ifte.factor} (68%) create mode 100644 library/test/x86-compiler/simple.factor diff --git a/library/compiler/compiler-macros.factor b/library/compiler/compiler-macros.factor index ba67d7d4d5..d941319e31 100644 --- a/library/compiler/compiler-macros.factor +++ b/library/compiler/compiler-macros.factor @@ -61,10 +61,14 @@ USE: alien 4 DATASTACK I+[I] 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 datastack, store pointer to datastack top in EAX. - DATASTACK EAX [I]>R - 4 EAX R-I + PEEK-DS EAX DATASTACK R>[I] ; : SELF-CALL ( name -- ) @@ -72,8 +76,8 @@ USE: alien dlsym-self CALL JUMP-FIXUP ; : TYPE-OF ( -- ) - #! Pop datastack, store type # in EAX. - POP-DS + #! Peek datastack, store type # in EAX. + PEEK-DS EAX PUSH-[R] "type_of" SELF-CALL - 4 ESI R-I ; + 4 ESP R+I ; diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor index 552a0b3e73..8a8d044dfe 100644 --- a/library/compiler/compiler.factor +++ b/library/compiler/compiler.factor @@ -35,6 +35,7 @@ USE: logic USE: math USE: namespaces USE: parser +USE: prettyprint USE: stack USE: strings USE: unparser @@ -67,20 +68,31 @@ SYMBOL: compiled-xts 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. +! "fixup-xts" is a list of [ where word relative ] pairs; the xt +! of word when its done compiling will be written to the offset, +! relative to the offset. SYMBOL: deferred-xts -: defer-xt ( word where -- ) - #! After word is compiled, put a call to it at offset. - deferred-xts acons@ ; +: defer-xt ( word where relative -- ) + #! After word is compiled, put its XT at where, relative. + 3list deferred-xts cons@ ; -: fixup-deferred-xt ( where word -- ) - compiled-xt swap JUMP-FIXUP ; +: compiled? ( word -- ? ) + #! 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 ( -- ) - deferred-xts get [ uncons fixup-deferred-xt ] each + deferred-xts get [ + uncons uncons car fixup-deferred-xt + ] each deferred-xts off ; ! Words being compiled are consed onto this list. When a word @@ -91,8 +103,11 @@ SYMBOL: deferred-xts SYMBOL: compile-words : postpone-word ( word -- ) - t over "compiled" set-word-property - compile-words cons@ ; + dup compiled? [ + drop + ] [ + t over "compiled" set-word-property compile-words cons@ + ] ifte ; ! During compilation, these two variables store pending ! literals. Literals are either consumed at compile-time by @@ -135,14 +150,11 @@ SYMBOL: compile-callstack : tail? ( -- ? ) compile-callstack get vector-empty? ; -: 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) - dup compiled? [ dup postpone-word ] unless - commit-literals tail? [ JUMP ] [ CALL ] ifte defer-xt ; + dup postpone-word + commit-literals tail? [ JUMP ] [ CALL ] ifte + compiled-offset defer-xt ; : compile-word ( word -- ) #! If a word has a compiling property, then it has special diff --git a/library/compiler/words.factor b/library/compiler/generic.factor similarity index 64% rename from library/compiler/words.factor rename to library/compiler/generic.factor index 28ff12735f..93345781af 100644 --- a/library/compiler/words.factor +++ b/library/compiler/generic.factor @@ -32,72 +32,53 @@ USE: stack USE: kernel USE: math USE: lists +USE: vectors -: 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 ; - -: 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 ) +: compile-table-jump ( start-fixup -- end-fixup ) #! The 32-bit address of the code after the jump table #! should be written to end-fixup. #! The jump table must immediately follow this macro. tail? [ 0 ] [ 0 PUSH-I compiled-offset 4 - ] ifte >r ( start-fixup r:end-fixup ) EAX JUMP-[R] + cell compile-aligned compiled-offset swap set-compiled-cell ( update the ADD ) r> ; -: BEGIN-JUMP-TABLE ( -- end-fixup ) +: begin-jump-table ( -- end-fixup ) #! Compile a piece of code that jumps to an offset in a #! jump table indexed by the type of the Factor object in #! EAX. TYPE-OF 2 EAX R<r dup type r> vector-nth execute ; - BEGIN-JUMP-TABLE - ! write table now - END-JUMP-TABLE ; + begin-jump-table + pop-literal compile-jump-table + end-jump-table ; -[ - [ ifte compile-ifte ] - [ generic compile-generic ] -] [ - unswons "compiling" set-word-property -] each +[ compile-generic ] \ generic "compiling" set-word-property diff --git a/library/compiler/ifte.factor b/library/compiler/ifte.factor new file mode 100644 index 0000000000..3c919a8d75 --- /dev/null +++ b/library/compiler/ifte.factor @@ -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 diff --git a/library/compiler/interpret-only.factor b/library/compiler/interpret-only.factor new file mode 100644 index 0000000000..35adf3eea8 --- /dev/null +++ b/library/compiler/interpret-only.factor @@ -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 diff --git a/library/platform/native/boot-stage2.factor b/library/platform/native/boot-stage2.factor index dd4bf4f13e..cb1f2c870d 100644 --- a/library/platform/native/boot-stage2.factor +++ b/library/platform/native/boot-stage2.factor @@ -139,7 +139,9 @@ USE: stdio "/library/compiler/assembly-x86.factor" "/library/compiler/compiler-macros.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-macros.factor" "/library/compiler/alien.factor" diff --git a/library/platform/native/parse-syntax.factor b/library/platform/native/parse-syntax.factor index 0cc2ac58d8..fa1bbf4402 100644 --- a/library/platform/native/parse-syntax.factor +++ b/library/platform/native/parse-syntax.factor @@ -94,6 +94,11 @@ USE: unparser ! Symbols : 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 : DEFER: CREATE drop ; parsing : USE: scan "use" cons@ ; parsing diff --git a/library/platform/native/types.factor b/library/platform/native/types.factor index a842090fdf..793b8916d5 100644 --- a/library/platform/native/types.factor +++ b/library/platform/native/types.factor @@ -70,3 +70,7 @@ IN: kernel [ 103 | "fixnum/bignum/ratio/float/complex" ] [ 104 | "fixnum/string" ] ] assoc ; + +: num-types ( -- n ) + #! One more than the maximum value from type-of. + 17 ; diff --git a/library/test/x86-compiler/generic.factor b/library/test/x86-compiler/generic.factor new file mode 100644 index 0000000000..22bbdc0b81 --- /dev/null +++ b/library/test/x86-compiler/generic.factor @@ -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 diff --git a/library/test/x86-compiler/compiler.factor b/library/test/x86-compiler/ifte.factor similarity index 68% rename from library/test/x86-compiler/compiler.factor rename to library/test/x86-compiler/ifte.factor index cdda7dc9a8..a6f14b1bb6 100644 --- a/library/test/x86-compiler/compiler.factor +++ b/library/test/x86-compiler/ifte.factor @@ -4,40 +4,10 @@ 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 - : dummy-ifte-1 t [ ] [ ] ifte ; compiled [ ] [ dummy-ifte-1 ] unit-test diff --git a/library/test/x86-compiler/simple.factor b/library/test/x86-compiler/simple.factor new file mode 100644 index 0000000000..ef296e39e3 --- /dev/null +++ b/library/test/x86-compiler/simple.factor @@ -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