linerization of generic, 2generic

TODO.FACTOR.txt

@@ -13,12 +13,10 @@
 - optimizer rewrite stack ops
 - alien-call need special nodes
 - mutual recursion is borked with certain branch order
-- fix inference of + = and others
 
 + linearizer/generator:
 
 - peephole optimizer
-- linearize generic, 2generic
 - getenv/setenv: if literal arg, compile as a load/store
 - compiler: drop literal peephole optimization
 

library/bootstrap/boot-stage2.factor

@@ -139,6 +139,7 @@ USE: stdio
     "/library/tools/jedit.factor"
 
     "/library/cli.factor"
+    "/library/sdl/hsv.factor"
 ] [
     dup print
     run-resource
@@ -163,13 +164,10 @@ cpu "x86" = [
 !        "/library/sdl/sdl-gfx.factor"
 !        "/library/sdl/sdl-keysym.factor"
 !        "/library/sdl/sdl-utils.factor"
-!        "/library/sdl/hsv.factor"
     ] [
         dup print
         run-resource
     ] each
-] [
+] when
-    "/library/compiler/dummy-compiler.factor" dup print run-resource
-] ifte
 
 "/library/bootstrap/init-stage2.factor" dup print run-resource

library/compiler/compiler-macros.factor

@@ -1,70 +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: alien
-
-: LITERAL ( cell -- )
-    #! Push literal on data stack.
-    4 ESI R+I
-    ESI I>[R] ;
-
-: [LITERAL] ( cell -- )
-    #! Push complex literal on data stack by following an
-    #! indirect pointer.
-    4 ESI R+I
-    EAX [I]>R
-    EAX ESI R>[R] ;
-
-: PUSH-DS ( -- )
-    #! Push contents of EAX onto datastack.
-    4 ESI R+I
-    EAX ESI R>[R] ;
-
-: POP-DS ( -- )
-    #! Pop datastack, store pointer to datastack top in EAX.
-    ESI EAX [R]>R
-    4 ESI R-I ;
-
-: SELF-CALL ( name -- )
-    #! Call named C function in Factor interpreter executable.
-    dlsym-self CALL JUMP-FIXUP ;
-
-: TYPE ( -- )
-    #! Peek datastack, store type # in EAX.
-    ESI PUSH-[R]
-    "type_of" SELF-CALL
-    4 ESP R+I ;
-
-: ARITHMETIC-TYPE ( -- )
-    #! Peek top two on datastack, store arithmetic type # in EAX.
-    ESI EAX R>R
-    EAX PUSH-[R]
-    4 EAX R-I
-    EAX PUSH-[R]
-    "arithmetic_type" SELF-CALL
-    8 ESP R+I ;

library/compiler/compiler.factor

@@ -52,7 +52,13 @@ USE: words
 
 : (compile) ( word -- )
     #! Should be called inside the with-compiler scope.
-    begin-compiling dataflow optimize linearize generate ;
+    begin-compiling dataflow ( optimize ) linearize generate ;
+
+: precompile ( word -- )
+    #! Print linear IR of word.
+    [
+        word-parameter dataflow optimize linearize [.]
+    ] with-scope ;
 
 : compile-postponed ( -- )
     compile-words get [

library/compiler/dummy-compiler.factor

@@ -1,5 +0,0 @@
-! Loaded on non-x86 platforms.
-IN: compiler
-
-: init-assembler ;
-: compile-all ;

library/compiler/generator-x86.factor

@@ -38,6 +38,7 @@ USE: namespaces
 USE: stack
 USE: strings
 USE: words
+USE: vectors
 
 : LITERAL ( cell -- )
     #! Push literal on data stack.
@@ -78,21 +79,6 @@ USE: words
     #! Call named C function in Factor interpreter executable.
     dlsym-self CALL JUMP-FIXUP ;
 
-: TYPE ( -- )
-    #! Peek datastack, store type # in EAX.
-    ESI PUSH-[R]
-    "type_of" SELF-CALL
-    4 ESP R+I ;
-
-: ARITHMETIC-TYPE ( -- )
-    #! Peek top two on datastack, store arithmetic type # in EAX.
-    ESI EAX R>R
-    EAX PUSH-[R]
-    4 EAX R-I
-    EAX PUSH-[R]
-    "arithmetic_type" SELF-CALL
-    8 ESP R+I ;
-
 #push [ compile-literal ] "generator" set-word-property
 
 #call [
@@ -126,10 +112,70 @@ USE: words
     EAX ESI R>[R]
 ] "generator" set-word-property
 
+! This is crap
 #swap [ drop \ swap CALL compiled-offset defer-xt ] "generator" set-word-property
 #over [ drop \ over CALL compiled-offset defer-xt ] "generator" set-word-property
+#pick [ drop \ pick CALL compiled-offset defer-xt ] "generator" set-word-property
 #nip [ drop \ nip CALL compiled-offset defer-xt ] "generator" set-word-property
 #tuck [ drop \ tuck CALL compiled-offset defer-xt ] "generator" set-word-property
 #rot [ drop \ rot CALL compiled-offset defer-xt ] "generator" set-word-property
 #>r [ drop \ >r CALL compiled-offset defer-xt ] "generator" set-word-property
 #r> [ drop \ r> CALL compiled-offset defer-xt ] "generator" set-word-property
+
+: begin-jump-table ( -- )
+    #! Compile a piece of code that jumps to an offset in a
+    #! jump table indexed by the type of the Factor object in
+    #! EAX.
+    #! The jump table must immediately follow this macro.
+    2 EAX R<<I ( -- fixup )
+    EAX+/PARTIAL
+    EAX JUMP-[R]
+    cell compile-aligned
+    compiled-offset swap set-compiled-cell ( fixup -- ) ;
+
+: jump-table-entry ( word -- )
+    #! Jump table entries are absolute addresses.
+    ( dup postpone-word )
+    compiled-offset 0 compile-cell 0 defer-xt ;
+
+: check-jump-table ( vtable -- )
+    length num-types = [
+        "Jump table must have " num-types " entries" cat3 throw
+    ] unless ;
+
+: compile-jump-table ( vtable -- )
+    #! Compile a table of words as a word-array of XTs.
+    begin-jump-table
+    dup check-jump-table
+    [ jump-table-entry ] each ;
+
+: TYPE ( -- )
+    #! Peek datastack, store type # in EAX.
+    ESI PUSH-[R]
+    "type_of" SELF-CALL
+    4 ESP R+I ;
+
+: compile-generic ( vtable -- )
+    #! Compile a faster alternative to
+    #! : generic ( obj vtable -- )
+    #!     >r dup type r> vector-nth execute ;
+    TYPE  compile-jump-table ;
+
+#generic [ compile-generic ] "generator" set-word-property
+
+: ARITHMETIC-TYPE ( -- )
+    #! Peek top two on datastack, store arithmetic type # in EAX.
+    ESI EAX R>R
+    EAX PUSH-[R]
+    4 EAX R-I
+    EAX PUSH-[R]
+    "arithmetic_type" SELF-CALL
+    8 ESP R+I ;
+
+: compile-2generic ( vtable -- )
+    #! Compile a faster alternative to
+    #! : 2generic ( obj vtable -- )
+    #!     >r 2dup arithmetic-type r> vector-nth execute ;
+    ARITHMETIC-TYPE  compile-jump-table ;
+
+#2generic [ compile-2generic ] "generator" set-word-property

library/compiler/generic.factor

@@ -1,93 +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
-USE: vectors
-
-: begin-jump-table ( -- start-fixup end-fixup )
-    2 EAX R<<I
-    EAX+/PARTIAL
-    tail? [ 0 ] [ 0 PUSH-I compiled-offset 4 - ] ifte ;
-
-: compile-table-jump ( start-fixup -- 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.
-    #! 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.
-    EAX JUMP-[R]
-    cell compile-aligned
-    compiled-offset swap set-compiled-cell ( update the ADD ) ;
-
-: jump-table-entry ( word -- )
-    #! Jump table entries are absolute addresses.
-    dup postpone-word
-    compiled-offset 0 compile-cell 0 defer-xt ;
-
-: end-jump-table ( end-fixup -- )
-    #! update the PUSH.
-    dup 0 = [
-        drop
-    ] [
-        compiled-offset swap set-compiled-cell
-    ] ifte ;
-
-: (compile-jump-table) ( vtable -- )
-    num-types [
-        over ?vector-nth jump-table-entry
-    ] times* drop ;
-
-: compile-jump-table ( vtable -- )
-    #! Compile a table of words as a word-array of XTs.
-    begin-jump-table >r
-    compile-table-jump
-    (compile-jump-table)
-    r> end-jump-table ;
-
-: compile-generic ( compile-time: vtable -- )
-    #! Compile a faster alternative to
-    #! : generic ( obj vtable -- )
-    #!     >r dup type r> vector-nth execute ;
-    pop-literal commit-literals
-    TYPE  compile-jump-table ;
-
-: compile-2generic ( compile-time: vtable -- )
-    #! Compile a faster alternative to
-    #! : 2generic ( obj vtable -- )
-    #!     >r 2dup arithmetic-type r> vector-nth execute ;
-    pop-literal commit-literals
-    ARITHMETIC-TYPE  compile-jump-table ;
-
-\ generic [ compile-generic ] "compiling" set-word-property
-\ 2generic [ compile-2generic ] "compiling" set-word-property

library/compiler/ifte.factor

@@ -1,87 +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
-
-: compile-test ( -- )
-    POP-DS
-    ! condition is now in EAX
-    f address EAX CMP-I-R ;
-
-: compile-f-test ( -- fixup )
-    #! Push addr where we write the branch target address.
-    compile-test
-    ! jump w/ address added later
-    JE ;
-
-: compile-t-test ( -- fixup )
-    #! Push addr where we write the branch target address.
-    compile-test
-    ! jump w/ address added later
-    JNE ;
-
-: 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? [ RET ] when [ branch-target ] when* ;
-
-: 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-when ( compile-time: true -- )
-    pop-literal  commit-literals
-    compile-f-test >r
-    ( t -- ) compile-quot
-    r> end-if ;
-
-: compile-unless ( compile-time: false -- )
-    pop-literal  commit-literals
-    compile-t-test >r
-    ( f -- ) compile-quot
-    r> end-if ;
-
-\ ifte [ compile-ifte ] "compiling" set-word-property
-\ when [ compile-when ] "compiling" set-word-property
-\ unless [ compile-unless ] "compiling" set-word-property

library/compiler/linearizer.factor

@@ -33,6 +33,10 @@ USE: namespaces
 USE: inference
 USE: combinators
 
+! The linear IR is close to assembly language. It also resembles
+! Forth code in some sense. It exists so that pattern matching
+! optimization can be performed against it.
+
 ! Linear IR nodes. This is in addition to the symbols already
 ! defined in dataflow vocab.
 
@@ -79,6 +83,25 @@ SYMBOL: #jump ( tail-call )
     swap (linearize) ( true branch )
     label, ( branch target of false branch end ) ;
 
+: generic-head ( param op -- end label/param )
+    #! Output the jump table insn and return a list of
+    #! label/branch pairs.
+    >r
+    <label> ( end label ) swap
+    [ <label> cons ] map
+    dup [ cdr ] map r> swons , ;
+
+: generic-body ( end label/param -- )
+    #! Output each branch, with a jump to the end label.
+    [
+        uncons label,  (linearize)  dup #jump-label swons ,
+    ] each drop ;
+
+: linearize-generic ( param op -- )
+    #! The parameter is a list of lists, each one is a branch to
+    #! take in case the top of stack has that type.
+    generic-head dupd generic-body label, ;
+
 #label [
     dup [ node-label get ] bind label,
     [ node-param get ] bind (linearize)
@@ -87,3 +110,11 @@ SYMBOL: #jump ( tail-call )
 #ifte [
     [ node-param get ] bind linearize-ifte
 ] "linearizer" set-word-property
+
+#generic [
+    [ node-param get node-op get ] bind linearize-generic
+] "linearizer" set-word-property
+
+#2generic [
+    [ node-param get node-op get ] bind linearize-generic
+] "linearizer" set-word-property

library/namespaces.factor

@@ -105,7 +105,7 @@ USE: vectors
     #! Execute the quotation with the variable value on the
     #! stack. The set the variable to the return value of the
     #! quotation.
-    >r dup get r> rot slip set ;
+    >r dup get r> rot slip set ; inline
 
 : bind ( namespace quot -- )
     #! Execute a quotation with a namespace on the namestack.

library/primitives.factor

@@ -82,7 +82,7 @@ USE: words
     [ >float                 " n -- float "                       [ 1 | 1 ] ]
     [ numerator              " a/b -- a "                         [ 1 | 1 ] ]
     [ denominator            " a/b -- b "                         [ 1 | 1 ] ]
-    [ fraction>              " a b -- a/b "                       [ 1 | 1 ] ]
+    [ fraction>              " a b -- a/b "                       [ 2 | 1 ] ]
     [ str>float              " str -- float "                     [ 1 | 1 ] ]
     [ unparse-float          " float -- str "                     [ 1 | 1 ] ]
     [ float>bits             " float -- n "                       [ 1 | 1 ] ]

library/test/compiler/optimizer.factor

@@ -0,0 +1,15 @@
+IN: scratchpad
+USE: test
+USE: compiler
+USE: inference
+USE: words
+USE: math
+USE: combinators
+
+: foo 1 2 3 ;
+
+[ [ ] ] [ \ foo word-parameter dataflow kill-set ] unit-test
+
+[ [ [ + ] [ - ] ] ] [ [ 3 4 1 2 > [ + ] [ - ] ifte ] dataflow kill-set ] unit-test
+
+[ [ [ 1 ] [ 2 ] ] ] [ [ [ 1 ] [ 2 ] ifte ] dataflow kill-set ] unit-test

library/test/test.factor

@@ -113,20 +113,20 @@ USE: unparser
         "parsing-word"
         "inference"
         "dataflow"
-        "optimizer"
         "interpreter"
+        "hsv"
     ] [
         test
     ] each
     
     cpu "x86" = [
         [
-            "hsv"
+            "compiler/optimizer"
-            "x86-compiler/simple"
+            "compiler/simple"
-            "x86-compiler/stack"
+            "compiler/stack"
-            "x86-compiler/ifte"
+            "compiler/ifte"
-            "x86-compiler/generic"
+            "compiler/generic"
-            "x86-compiler/bail-out"
+            "compiler/bail-out"
         ] [
             test
         ] each