'generic' word now compiled

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
+    PEEK-DS
-    4 EAX R-I
     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.
+    #! Peek datastack, store type # in EAX.
-    POP-DS
+    PEEK-DS
     EAX PUSH-[R]
     "type_of" SELF-CALL
-    4 ESI R-I ;
+    4 ESP R+I ;

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
+! "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
 
-: 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 ( -- )
-    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
+    dup compiled? [
-    compile-words cons@ ;
+        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
+    dup postpone-word
-    commit-literals tail? [ JUMP ] [ CALL ] ifte defer-xt ;
+    commit-literals tail? [ JUMP ] [ CALL ] ifte
+    compiled-offset defer-xt ;
 
 : compile-word ( word -- )
     #! If a word has a compiling property, then it has special

library/compiler/generic.factor

@@ -32,72 +32,53 @@ USE: stack
 USE: kernel
 USE: math
 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
     #! 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<<I
     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 ;
 
 : compile-generic ( compile-time: vtable -- )
     #! Compile a faster alternative to
     #! : generic ( obj vtable -- )
     #!     >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

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

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

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"

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

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 ;

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

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

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