]> gitweb.factorcode.org Git - factor.git/commitdiff
'generic' word now compiled
authorSlava Pestov <slava@factorcode.org>
Sat, 2 Oct 2004 02:02:54 +0000 (02:02 +0000)
committerSlava Pestov <slava@factorcode.org>
Sat, 2 Oct 2004 02:02:54 +0000 (02:02 +0000)
13 files changed:
library/compiler/compiler-macros.factor
library/compiler/compiler.factor
library/compiler/generic.factor [new file with mode: 0644]
library/compiler/ifte.factor [new file with mode: 0644]
library/compiler/interpret-only.factor [new file with mode: 0644]
library/compiler/words.factor [deleted file]
library/platform/native/boot-stage2.factor
library/platform/native/parse-syntax.factor
library/platform/native/types.factor
library/test/x86-compiler/compiler.factor [deleted file]
library/test/x86-compiler/generic.factor [new file with mode: 0644]
library/test/x86-compiler/ifte.factor [new file with mode: 0644]
library/test/x86-compiler/simple.factor [new file with mode: 0644]

index ba67d7d4d5ca237473f84bbd0b72665a57f9397c..d941319e314d66956192f55131c5ae87041fa07c 100644 (file)
@@ -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 ;
index 552a0b3e736c62d137469231f4f619753759e31e..8a8d044dfe723427cb83807b0a1c61ca8f13e61c 100644 (file)
@@ -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/generic.factor b/library/compiler/generic.factor
new file mode 100644 (file)
index 0000000..9334578
--- /dev/null
@@ -0,0 +1,84 @@
+! :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
+USE: vectors
+
+: 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 )
+    #! 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
+    compile-table-jump ;
+
+: jump-table-entry ( word -- )
+    #! Jump table entries are absolute addresses.
+    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
+    ] [
+        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
+    pop-literal compile-jump-table
+    end-jump-table ;
+
+[ compile-generic ] \ generic "compiling" set-word-property
diff --git a/library/compiler/ifte.factor b/library/compiler/ifte.factor
new file mode 100644 (file)
index 0000000..3c919a8
--- /dev/null
@@ -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 (file)
index 0000000..35adf3e
--- /dev/null
@@ -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/compiler/words.factor b/library/compiler/words.factor
deleted file mode 100644 (file)
index 28ff127..0000000
+++ /dev/null
@@ -1,103 +0,0 @@
-! :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
-
-: 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 )
-    #! 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]
-    compiled-offset swap set-compiled-cell ( update the ADD )
-    r> ;
-
-: 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 ;
-
-: END-JUMP-TABLE ( end-fixup -- )
-    compiled-offset dup 0 = [
-        2drop
-    ] [
-        set-compiled-cell ( update the PUSH )
-    ] ifte ;
-
-: compile-generic ( compile-time: vtable -- )
-    #! Compile a faster alternative to
-    #! : generic ( obj vtable -- )
-    #!     >r dup type r> vector-nth execute ;
-    BEGIN-JUMP-TABLE
-    ! write table now
-    END-JUMP-TABLE ;
-
-[
-    [ ifte compile-ifte ]
-    [ generic compile-generic ]
-] [
-    unswons "compiling" set-word-property
-] each
index dd4bf4f13e64d2d2f26156e6ed575e3a0a80d18c..cb1f2c870d38861531e20167b08058296c9089ab 100644 (file)
@@ -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"
index 0cc2ac58d87c6cf4f662a5ac36d7e303d2535848..fa1bbf44028a5916943898f47503734fc7428bf5 100644 (file)
@@ -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
index a842090fdf5f3b670e0a39a0c3ff314909785f05..793b8916d5ce5eb07e1be9d2a47933da4637741f 100644 (file)
@@ -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/compiler.factor b/library/test/x86-compiler/compiler.factor
deleted file mode 100644 (file)
index cdda7dc..0000000
+++ /dev/null
@@ -1,93 +0,0 @@
-IN: scratchpad
-USE: compiler
-USE: test
-USE: math
-USE: stack
-USE: kernel
-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
-
-: dummy-ifte-2 f [ ] [ ] ifte ; compiled
-
-[ ] [ dummy-ifte-2 ] unit-test
-
-: dummy-ifte-3 t [ 1 ] [ 2 ] ifte ; compiled
-
-[ 1 ] [ dummy-ifte-3 ] unit-test
-
-: dummy-ifte-4 f [ 1 ] [ 2 ] ifte ; compiled
-
-[ 2 ] [ dummy-ifte-4 ] unit-test
-
-: dummy-ifte-5 0 dup 1 fixnum<= [ drop 1 ] [ ] ifte ; compiled
-
-[ 1 ] [ dummy-ifte-5 ] unit-test
-
-: dummy-ifte-6
-    dup 1 <= [
-        drop 1
-    ] [
-        1 fixnum- dup swap 1 fixnum- fixnum+
-    ] ifte ;
-
-[ 17 ] [ 10 dummy-ifte-6 ] unit-test
-
-: dead-code-rec
-    t [
-        #{ 3 2 }
-    ] [
-        dead-code-rec
-    ] ifte ; compiled
-
-[ #{ 3 2 } ] [ dead-code-rec ] unit-test
-
-: one-rec [ f one-rec ] [ "hi" ] ifte ; compiled
-
-[ "hi" ] [ t one-rec ] unit-test
-
-: after-ifte-test
-    t [ ] [ ] ifte 5 ; compiled
-
-[ 5 ] [ after-ifte-test ] unit-test
-
-DEFER: countdown-b
-
-: countdown-a ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-b ] ifte ;
-: countdown-b ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-a ] ifte ; compiled
-
-[ ] [ 10 countdown-b ] unit-test
diff --git a/library/test/x86-compiler/generic.factor b/library/test/x86-compiler/generic.factor
new file mode 100644 (file)
index 0000000..22bbdc0
--- /dev/null
@@ -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/ifte.factor b/library/test/x86-compiler/ifte.factor
new file mode 100644 (file)
index 0000000..a6f14b1
--- /dev/null
@@ -0,0 +1,63 @@
+IN: scratchpad
+USE: compiler
+USE: test
+USE: math
+USE: stack
+USE: kernel
+USE: logic
+USE: combinators
+USE: words
+
+: dummy-ifte-1 t [ ] [ ] ifte ; compiled
+
+[ ] [ dummy-ifte-1 ] unit-test
+
+: dummy-ifte-2 f [ ] [ ] ifte ; compiled
+
+[ ] [ dummy-ifte-2 ] unit-test
+
+: dummy-ifte-3 t [ 1 ] [ 2 ] ifte ; compiled
+
+[ 1 ] [ dummy-ifte-3 ] unit-test
+
+: dummy-ifte-4 f [ 1 ] [ 2 ] ifte ; compiled
+
+[ 2 ] [ dummy-ifte-4 ] unit-test
+
+: dummy-ifte-5 0 dup 1 fixnum<= [ drop 1 ] [ ] ifte ; compiled
+
+[ 1 ] [ dummy-ifte-5 ] unit-test
+
+: dummy-ifte-6
+    dup 1 <= [
+        drop 1
+    ] [
+        1 fixnum- dup swap 1 fixnum- fixnum+
+    ] ifte ;
+
+[ 17 ] [ 10 dummy-ifte-6 ] unit-test
+
+: dead-code-rec
+    t [
+        #{ 3 2 }
+    ] [
+        dead-code-rec
+    ] ifte ; compiled
+
+[ #{ 3 2 } ] [ dead-code-rec ] unit-test
+
+: one-rec [ f one-rec ] [ "hi" ] ifte ; compiled
+
+[ "hi" ] [ t one-rec ] unit-test
+
+: after-ifte-test
+    t [ ] [ ] ifte 5 ; compiled
+
+[ 5 ] [ after-ifte-test ] unit-test
+
+DEFER: countdown-b
+
+: countdown-a ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-b ] ifte ;
+: countdown-b ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-a ] ifte ; compiled
+
+[ ] [ 10 countdown-b ] unit-test
diff --git a/library/test/x86-compiler/simple.factor b/library/test/x86-compiler/simple.factor
new file mode 100644 (file)
index 0000000..ef296e3
--- /dev/null
@@ -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