working on compiler

TODO.FACTOR.txt

@@ -1,7 +1,21 @@
 FFI:
 - is signed -vs- unsigned pointers an issue?
 
+- BIN: 2: bad
+
 - symbols are not primitives
+- compiled? messy
+- compiler: drop literal peephole optimization
+- compiler: type-of { ... } call
+            type-of { ... } execute
+	    arithmetic-type { ... } call
+	    arithmetic-type { ... } execute
+- ditch ds/cs envs, just use dlsym instead
+- getenv/setenv: if literal arg, compile as a load/store
+- inline words
+- raise an error when compiling something we can't
+  call, datastack/callstack, set-datastack/callstack,
+  execute
 
 [error] SideKick$BufferChangeHandler: We have cplusplus.xml (/home/slava/jEdit/modes/) but got event for DefaultInputHandler.java (/home/slava/jEdit/org/gjt/sp/jedit/gui/)
 [error] SideKick$BufferChangeHandler: We have cplusplus.xml (/home/slava/jEdit/modes/) but got event for DefaultInputHandler.java (/home/slava/jEdit/org/gjt/sp/jedit/gui/)

library/compiler/alien-macros.factor

@@ -36,15 +36,11 @@ USE: stack
 
 : UNBOX ( name -- )
     #! Move top of datastack to C stack.
-    dlsym-self CALL JUMP-FIXUP
-    EAX PUSH-R ;
+    SELF-CALL  EAX PUSH-R ;
 
 : BOX ( name -- )
     #! Move EAX to datastack.
-    24 ESP R-I
-    EAX PUSH-R
-    dlsym-self CALL JUMP-FIXUP
-    28 ESP R+I ;
+    EAX PUSH-R  SELF-CALL  4 ESP R+I ;
 
 : PARAMETERS ( params -- count )
     #! Generate code for boxing a list of C types.

library/compiler/assembler.factor

@@ -52,11 +52,3 @@ USE: stack
 : compile-cell ( n -- )
     compiled-offset set-compiled-cell
     compiled-offset cell + set-compiled-offset ;
-
-: DATASTACK ( -- ptr )
-    #! A pointer to a pointer to the datastack top.
-    11 getenv ;
-
-: CALLSTACK ( -- ptr )
-    #! A pointer to a pointer to the callstack top.
-    12 getenv ;

library/compiler/assembly-x86.factor

@@ -41,12 +41,37 @@ USE: combinators
 : ESI 6 ;
 : EDI 7 ;
 
+: byte? -128 127 between? ;
+
+: eax/other ( reg quot quot -- )
+    #! Execute first quotation if reg is EAX, second quotation
+    #! otherwise, leaving reg on the stack.
+    pick EAX = [ drop nip call ] [ nip call ] ifte ;
+
+: byte/eax/cell ( imm reg byte eax cell -- )
+    #! Assemble an instruction with 3 forms; byte operand, any
+    #! register; eax register, cell operand; other register,
+    #! cell operand.
+    >r >r >r >r dup byte? [
+        r> r> call r> drop r> drop compile-byte
+    ] [
+        r> dup EAX = [
+            drop r> drop r> call r> drop compile-cell
+        ] [
+            r> drop r> drop r> call compile-cell
+        ] ifte
+    ] ifte ;
+
 : MOD-R/M ( r/m reg/opcode mod -- )
+    #! MOD-R/M is MOD REG/OPCODE R/M
     6 shift swap 3 shift bitor bitor compile-byte ;
 
 : PUSH-R ( reg -- )
     HEX: 50 + compile-byte ;
 
+: PUSH-[R] ( reg -- )
+    HEX: ff compile-byte BIN: 110 0 MOD-R/M ;
+
 : PUSH-I ( imm -- )
     HEX: 68 compile-byte compile-cell ;
 
@@ -62,12 +87,12 @@ USE: combinators
 
 : [I]>R ( imm reg -- )
     #! MOV INDIRECT <imm> TO <reg>
-    dup EAX = [
-        drop HEX: a1 compile-byte
+    [
+        HEX: a1 compile-byte
     ] [
         HEX: 8b compile-byte
         BIN: 101 swap 0 MOD-R/M
-    ] ifte compile-cell ;
+    ] eax/other compile-cell ;
 
 : I>[R] ( imm reg -- )
     #! MOV <imm> TO INDIRECT <reg>
@@ -75,12 +100,12 @@ USE: combinators
 
 : R>[I] ( reg imm -- )
     #! MOV <reg> TO INDIRECT <imm>.
-    over EAX = [
-        nip HEX: a3 compile-byte
+    swap [
+        HEX: a3 compile-byte
     ] [
         HEX: 89 compile-byte
-        swap BIN: 101 swap 0 MOD-R/M
-    ] ifte compile-cell ;
+        BIN: 101 swap 0 MOD-R/M
+    ] eax/other compile-cell ;
 
 : R>R ( reg reg -- )
     #! MOV <reg> TO <reg>.
@@ -101,43 +126,49 @@ USE: combinators
     compile-cell
     compile-cell ;
 
+: EAX+/PARTIAL ( -- fixup )
+    #! This is potentially bad. In the compilation of
+    #! generic and 2generic, we need to add something which is
+    #! only known later.
+    #!
+    #! Returns address of 32-bit immediate.
+    HEX: 05 compile-byte  compiled-offset  0 compile-cell ;
+
 : R+I ( imm reg -- )
     #! ADD <imm> TO <reg>, STORE RESULT IN <reg>
-    over -128 127 between? [
+    [
         HEX: 83 compile-byte
         0 BIN: 11 MOD-R/M
-        compile-byte
     ] [
-        dup EAX = [
-            drop HEX: 05 compile-byte
-        ] [
-            HEX: 81 compile-byte
-            0 BIN: 11 MOD-R/M
-        ] ifte
-        compile-cell
-    ] ifte ;
+        HEX: 05 compile-byte
+    ] [
+        HEX: 81 compile-byte
+        0 BIN: 11 MOD-R/M
+    ] byte/eax/cell ;
 
 : R-I ( imm reg -- )
     #! SUBTRACT <imm> FROM <reg>, STORE RESULT IN <reg>
-    over -128 127 between? [
+    [
         HEX: 83 compile-byte
         BIN: 101 BIN: 11 MOD-R/M
-        compile-byte
     ] [
-        dup EAX = [
-            drop HEX: 2d compile-byte
-        ] [
-            HEX: 81 compile-byte
-            BIN: 101 BIN: 11 MOD-R/M
-        ] ifte
-        compile-cell
-    ] ifte ;
+        HEX: 2d compile-byte
+    ] [
+        HEX: 81 compile-byte
+        BIN: 101 BIN: 11 MOD-R/M
+    ] byte/eax/cell ;
+
+: R<<I ( imm reg -- )
+    #! SHIFT <reg> BY <imm>, STORE RESULT IN <reg>
+    HEX: c1 compile-byte
+    BIN: 100 BIN: 11 MOD-R/M
+    compile-byte ;
 
 : CMP-I-[R] ( imm reg -- )
     #! There are two forms of CMP we assemble
     #! 83 38 03                cmpl   $0x3,(%eax)
     #! 81 38 33 33 33 00       cmpl   $0x333333,(%eax)
-    over -128 127 between? [
+    over byte? [
         HEX: 83 compile-byte
         BIN: 111 0 MOD-R/M
         compile-byte
@@ -160,9 +191,17 @@ USE: combinators
     #! Push address of branch for fixup
     HEX: e9 compile-byte  (JUMP) ;
 
+: JUMP-[R] ( reg -- )
+    #! JUMP TO INDIRECT <reg>.
+    HEX: ff compile-byte  BIN: 100 0 MOD-R/M ;
+
 : CALL ( -- fixup )
     HEX: e8 compile-byte  (JUMP) ;
 
+: CALL-[R] ( reg -- )
+    #! CALL INDIRECT <reg>.
+    HEX: ff compile-byte  BIN: 10 0 MOD-R/M ;
+
 : JE ( -- fixup )
     HEX: 0f compile-byte HEX: 84 compile-byte  (JUMP) ;
 

library/compiler/compiler-macros.factor

@@ -26,6 +26,15 @@
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 IN: compiler
+USE: alien
+
+: DATASTACK ( -- ptr )
+    #! A pointer to a pointer to the datastack top.
+    "ds" dlsym-self ;
+
+: CALLSTACK ( -- ptr )
+    #! A pointer to a pointer to the callstack top.
+    "cs" dlsym-self ;
 
 : LITERAL ( cell -- )
     #! Push literal on data stack.
@@ -57,3 +66,14 @@ IN: compiler
     DATASTACK EAX [I]>R
     4 EAX R-I
     EAX DATASTACK R>[I] ;
+
+: SELF-CALL ( name -- )
+    #! Call named C function in Factor interpreter executable.
+    dlsym-self CALL JUMP-FIXUP ;
+
+: TYPE-OF ( -- )
+    #! Pop datastack, store type # in EAX.
+    POP-DS
+    EAX PUSH-[R]
+    "type_of" SELF-CALL
+    4 ESI R-I ;

library/compiler/words.factor

@@ -33,7 +33,7 @@ USE: kernel
 USE: math
 USE: lists
 
-: compile-f-test ( -- fixup )
+: F-TEST ( -- fixup )
     #! Push addr where we write the branch target address.
     POP-DS
     ! ptr to condition is now in EAX
@@ -42,27 +42,62 @@ USE: lists
     JE ;
 
 : branch-target ( fixup -- )
-    cell compile-aligned compiled-offset swap JUMP-FIXUP ;
+    compiled-offset swap JUMP-FIXUP ;
 
-: compile-else ( fixup -- 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 ;
 
-: compile-end-if ( fixup -- )
+: END-IF ( fixup -- )
     tail? [ drop RET ] [ branch-target ] ifte ;
 
-: compile-ifte ( -- )
+: compile-ifte ( compile-time: true false -- )
     pop-literal pop-literal  commit-literals
-    compile-f-test >r
+    F-TEST >r
     ( t -- ) compile-quot
-    r> compile-else >r
+    r> ELSE >r
     ( f -- ) compile-quot
-    r> compile-end-if ;
+    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

library/image.factor

@@ -175,32 +175,21 @@ USE: words
     0 emit ;
 
 ! This is to handle mutually recursive words
-! It is a hack. A recursive word in the cdr of a
-! cons doesn't work! This never happends though.
-!
-! Eg : foo [ 5 | foo ] ;
 
-: fixup-word-later ( word -- )
-    image vector-length cons "word-fixups" get vector-push ;
-
-: fixup-word ( where word -- )
+: fixup-word ( word -- offset )
     dup pooled-object dup [
-        nip swap fixup
+        nip
     ] [
         drop "Not in image: " swap word-name cat2 throw
     ] ifte ;
 
 : fixup-words ( -- )
-    "word-fixups" get [ unswons fixup-word ] vector-each ;
+    "image" get [
+        dup word? [ fixup-word ] when
+    ] vector-map "image" set ;
 
 : 'word ( word -- pointer )
-    dup pooled-object dup [
-        nip
-    ] [
-        drop
-        ! Remember where we are, and add the reference later
-        dup fixup-word-later
-    ] ifte ;
+    dup pooled-object dup [ nip ] [ drop ] ifte ;
 
 ( Conses )
 
@@ -278,9 +267,8 @@ DEFER: '
 
     dup word-name "name" swons ,
     dup word-vocabulary "vocabulary" swons ,
-    "parsing" over word-property [ t "parsing" swons , ] when
+    "parsing" word-property [ t "parsing" swons , ] when
 
-    drop
     ,] ' ;
 
 : (worddef,) ( word primitive parameter -- )

library/lists.factor

@@ -380,20 +380,23 @@ DEFER: tree-contains?
         over cons? [ 2dup car= >r cdr= r> and ] [ 2drop f ] ifte
     ] ifte ;
 
-: cons-hashcode ( cons count -- hash )
+: (cons-hashcode) ( cons count -- hash )
     dup 0 = [
         2drop 0
     ] [
         over cons? [
             pred >r uncons r> tuck
-            cons-hashcode >r
-            cons-hashcode r>
+            (cons-hashcode) >r
+            (cons-hashcode) r>
             bitxor
         ] [
             drop hashcode
         ] ifte
     ] ifte ;
 
+: cons-hashcode ( cons -- hash )
+    4 (cons-hashcode) ;
+
 : list>vector ( list -- vector )
     dup length <vector> swap [ over vector-push ] each ;
 

library/platform/jvm/words.factor

@@ -42,11 +42,11 @@ USE: stack
         intern dup [ [ "def" get ] bind ] when
     ] unless ;
 
-: word-property ( pname word -- pvalue )
-    [ get ] bind ;
+: word-property ( word pname -- pvalue )
+    swap [ get ] bind ;
 
-: set-word-property ( pvalue pname word -- )
-    [ set ] bind ;
+: set-word-property ( pvalue word pname -- )
+    swap [ set ] bind ;
 
 : redefine ( word def -- )
     swap [ "def" set ] bind ;

library/platform/native/kernel.factor

@@ -51,56 +51,57 @@ USE: vectors
 ! 'generic words' system will be built later.
 
 : generic ( obj vtable -- )
-    over type swap vector-nth call ;
+    >r dup type r> vector-nth execute ;
 
-: 2generic ( n n map -- )
+: 2generic ( n n vtable -- )
     >r 2dup arithmetic-type r> vector-nth execute ;
 
+: default-hashcode drop 0 ;
+
 : hashcode ( obj -- hash )
     #! If two objects are =, they must have equal hashcodes.
     {
-        [ ]
-        [ word-hashcode ]
-        [ 4 cons-hashcode ]
-        [ drop 0 ]
-        [ >fixnum ]
-        [ >fixnum ]
-        [ drop 0 ]
-        [ drop 0 ]
-        [ drop 0 ]
-        [ vector-hashcode ]
-        [ str-hashcode ]
-        [ sbuf-hashcode ]
-        [ drop 0 ]
-        [ >fixnum ]
-        [ >fixnum ]
-        [ drop 0 ]
-        [ drop 0 ]
+        nop
+        word-hashcode
+        cons-hashcode
+        default-hashcode
+        >fixnum
+        >fixnum
+        default-hashcode
+        default-hashcode
+        default-hashcode
+        vector-hashcode
+        str-hashcode
+        sbuf-hashcode
+        default-hashcode
+        >fixnum
+        >fixnum
+        default-hashcode
+        default-hashcode
     } generic ;
 
-
 IN: math DEFER: number= ( defined later... )
 IN: kernel
 : = ( obj obj -- ? )
     #! Push t if a is isomorphic to b.
     {
-        [ number= ]
-        [ eq? ]
-        [ cons= ]
-        [ eq? ]
-        [ number= ]
-        [ number= ]
-        [ eq? ]
-        [ eq? ]
-        [ eq? ]
-        [ vector= ]
-        [ str= ]
-        [ sbuf= ]
-        [ eq? ]
-        [ number= ]
-        [ number= ]
-        [ eq? ]
-        [ eq? ]
+        number=
+        eq?
+        cons=
+        eq?
+        number=
+        number=
+        eq?
+        eq?
+        eq?
+        vector=
+        str=
+        sbuf=
+        eq?
+        number=
+        number=
+        eq?
+        eq?
     } generic ;
 
 : 2= ( a b c d -- ? )

library/platform/native/stack.factor

@@ -28,6 +28,7 @@
 IN: stack
 USE: vectors
 
+: nop ( -- ) ;
 : 2drop ( x x -- ) drop drop ;
 : 3drop ( x x x -- ) drop drop drop ;
 : 2dup ( x y -- x y x y ) over over ;

library/test/x86-compiler/asm-test.factor

@@ -1,5 +1,6 @@
 IN: scratchpad
 USE: compiler
+USE: stack
 
 0 EAX I>R
 0 ECX I>R
@@ -35,3 +36,12 @@ ECX ECX R>[R]
 4 ECX R-I
 65535 EAX R-I
 65535 ECX R-I
+
+EAX PUSH-R
+ECX PUSH-R
+EAX PUSH-[R]
+ECX PUSH-[R]
+65535 PUSH-I
+
+EAX JUMP-[R]
+ECX JUMP-[R]

library/test/x86-compiler/compiler.factor

@@ -7,8 +7,6 @@ USE: kernel
 USE: combinators
 USE: words
 
-"Hi." USE: stdio print
-
 : no-op ; compiled
 
 [ ] [ no-op ] unit-test
@@ -89,7 +87,7 @@ garbage-collection
 
 DEFER: countdown-b
 
-: countdown-a ( n -- ) dup 0 eq? [ drop ] [ pred countdown-b ] ifte ;
-: countdown-b ( n -- ) dup 0 eq? [ drop ] [ pred countdown-a ] ifte ; compiled
+: 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

native/run.h

@@ -11,8 +11,6 @@
 #define BOOT_ENV       8
 #define RUNQUEUE_ENV   9 /* used by library only */
 #define ARGS_ENV       10
-#define DS_ENV         11 /* ptr to base addr of datastack */
-#define CS_ENV         12 /* ptr to base addr of callstack */
 
 /* Profiling timer */
 struct itimerval prof_timer;

native/stack.c

@@ -14,10 +14,8 @@ void init_stacks(void)
 {
 	ds_bot = (CELL)alloc_guarded(STACK_SIZE);
 	reset_datastack();
-	userenv[DS_ENV] = tag_integer((CELL)&ds);
 	cs_bot = (CELL)alloc_guarded(STACK_SIZE);
 	reset_callstack();
-	userenv[CS_ENV] = tag_integer((CELL)&cs);
 	callframe = userenv[BOOT_ENV];
 }