compiler cleanups

library/compiler/alien-macros.factor

@@ -32,6 +32,10 @@ USE: lists
 USE: math
 USE: namespaces
 
+: SELF-CALL ( name -- )
+    #! Call named C function in Factor interpreter executable.
+    dlsym-self CALL JUMP-FIXUP ;
+
 : UNBOX ( name -- )
     #! Move top of datastack to C stack.
     SELF-CALL  EAX PUSH-R ;

library/compiler/assembly-x86.factor

@@ -170,6 +170,12 @@ USE: math
     BIN: 100 BIN: 11 MOD-R/M
     compile-byte ;
 
+: R>>I ( imm reg -- )
+    #! SHIFT <reg> BY <imm>, STORE RESULT IN <reg>
+    HEX: c1 compile-byte
+    BIN: 111 BIN: 11 MOD-R/M
+    compile-byte ;
+
 : CMP-I-R ( imm reg -- )
     #! There are three forms of CMP we assemble
     #! 83 f8 03                cmpl   $0x3,%eax

library/compiler/generator-x86.factor

@@ -28,24 +28,12 @@
 IN: compiler
 USE: alien
 USE: inference
-USE: errors
 USE: kernel
-USE: lists
-USE: math
 USE: namespaces
-USE: strings
 USE: words
-USE: vectors
 
 : DS ( -- address ) "ds" dlsym-self ;
 
-: PUSH-DS ( -- )
-    #! Push contents of EAX onto datastack.
-    DS ECX [I]>R
-    4 ECX R+I
-    EAX ECX R>[R]
-    ECX DS R>[I] ;
-
 : POP-DS ( -- )
     #! Pop datastack to EAX.
     DS ECX [I]>R
@@ -53,21 +41,6 @@ USE: vectors
     4 ECX R-I
     ECX DS R>[I] ;
 
-: PEEK-DS ( -- )
-    #! Peek datastack to EAX.
-    DS ECX [I]>R
-    ECX EAX [R]>R ;
-
-: PEEK-2-DS ( -- )
-    #! Peek second value on datastack to EAX.
-    DS ECX [I]>R
-    4 ECX R-I
-    ECX EAX [R]>R ;
-
-: SELF-CALL ( name -- )
-    #! Call named C function in Factor interpreter executable.
-    dlsym-self CALL JUMP-FIXUP ;
-
 #push-immediate [
     DS ECX [I]>R
     4 ECX R+I
@@ -110,75 +83,20 @@ USE: vectors
 
 #return [ drop RET ] "generator" set-word-property
 
-[
+#dispatch [
-    [ #drop drop ]
-    [ #dup  dup  ]
-    [ #swap swap ]
-    [ #over over ]
-    [ #pick pick ]
-    [ #>r   >r   ]
-    [ #r>   r>   ]
-] [
-    uncons [
-        car CALL compiled-offset defer-xt drop
-    ] cons "generator" set-word-property
-] each
-
-: 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
+    #! jump table indexed by the fixnum at the top of the stack.
-    #! EAX.
     #! The jump table must immediately follow this macro.
-    2 EAX R<<I ( -- fixup )
+    drop
+    POP-DS
+    1 EAX R>>I ( -- fixup )
     EAX+/PARTIAL
     EAX JUMP-[R]
     cell compile-aligned
-    compiled-offset swap set-compiled-cell ( fixup -- ) ;
+    compiled-offset swap set-compiled-cell ( fixup -- )
+] "generator" set-word-property
 
-: jump-table-entry ( word -- )
+#target [
     #! Jump table entries are absolute addresses.
-    ( dup postpone-word )
+    compiled-offset 0 compile-cell 0 defer-xt
-    compiled-offset 0 compile-cell 0 defer-xt ;
+] "generator" set-word-property
-
-: 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.
-    PEEK-DS
-    EAX 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.
-    PEEK-DS
-    EAX PUSH-R
-    PEEK-2-DS
-    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/linearizer.factor

@@ -32,6 +32,8 @@ USE: lists
 USE: math
 USE: namespaces
 USE: words
+USE: strings
+USE: errors
 
 ! The linear IR is close to assembly language. It also resembles
 ! Forth code in some sense. It exists so that pattern matching
@@ -47,6 +49,11 @@ SYMBOL: #jump-label ( unconditional branch )
 SYMBOL: #jump ( tail-call )
 SYMBOL: #return-to ( push addr on C stack )
 
+! #dispatch is linearized as #dispatch followed by a #target
+! for each dispatch table entry. The linearizer ensures the
+! correct number of #targets is emitted.
+SYMBOL: #target ( part of jump table )
+
 : linear, ( node -- )
     #! Add a node to the linear IR.
     [ node-op get node-param get ] bind cons , ;
@@ -128,31 +135,45 @@ SYMBOL: #return-to ( push addr on C stack )
     [ node-param get ] bind linearize-ifte
 ] "linearizer" set-word-property
 
-: generic-head ( param op -- end label/param )
+: dispatch-head ( vtable -- end label/code )
     #! Output the jump table insn and return a list of
     #! label/branch pairs.
-    >r
+    [ #dispatch ] ,
     <label> ( end label ) swap
-    [ <label> cons ] map
+    [ <label> dup #target swons ,  cons ] map ;
-    dup [ cdr ] map r> swons , ;
 
-: generic-body ( end label/param -- )
+: dispatch-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 -- )
+: check-dispatch ( vtable -- )
+    length num-types = [
+        "Dispatch must have " num-types " entries" cat3 throw
+    ] unless ;
+
+: linearize-dispatch ( vtable -- )
     #! 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, ;
+    dup check-dispatch dispatch-head dupd dispatch-body label, ;
 
-#generic [
+#dispatch [
-    [ node-param get node-op get ] bind linearize-generic
+    [ node-param get ] bind linearize-dispatch
-] "linearizer" set-word-property
-
-#2generic [
-    [ node-param get node-op get ] bind linearize-generic
 ] "linearizer" set-word-property
 
 #values [ drop ] "linearizer" set-word-property
+
+[
+    [ #drop drop ]
+    [ #dup  dup  ]
+    [ #swap swap ]
+    [ #over over ]
+    [ #pick pick ]
+    [ #>r   >r   ]
+    [ #r>   r>   ]
+] [
+    uncons
+    [ car #call swons , drop ] cons
+    "linearizer" set-word-property
+] each

library/compiler/optimizer.factor

@@ -153,11 +153,7 @@ USE: prettyprint
     [ node-param get ] bind branches-call-label?
 ] "calls-label" set-word-property
 
-#generic [
+#dispatch [
-    [ node-param get ] bind branches-call-label?
-] "calls-label" set-word-property
-
-#2generic [
     [ node-param get ] bind branches-call-label?
 ] "calls-label" set-word-property
 
@@ -177,13 +173,9 @@ USE: prettyprint
 #ifte [ can-kill-branches? ] "can-kill" set-word-property
 #ifte [ kill-branches ] "kill-node" set-word-property
 
-#generic [ scan-branches ] "scan-literal" set-word-property
+#dispatch [ scan-branches ] "scan-literal" set-word-property
-#generic [ can-kill-branches? ] "can-kill" set-word-property
+#dispatch [ can-kill-branches? ] "can-kill" set-word-property
-#generic [ kill-branches ] "kill-node" set-word-property
+#dispatch [ kill-branches ] "kill-node" set-word-property
-
-#2generic [ scan-branches ] "scan-literal" set-word-property
-#2generic [ can-kill-branches? ] "can-kill" set-word-property
-#2generic [ kill-branches ] "kill-node" set-word-property
 
 ! Don't care about inputs to recursive combinator calls
 #call-label [ 2drop t ] "can-kill" set-word-property

library/inference/branches.factor

@@ -106,7 +106,8 @@ USE: hashtables
     [
         f infer-branch [
             d-in get meta-d get vector-length cons
-        ] bind recursive-state get set-base
+            recursive-state get set-base
+        ] bind
     ] [
         [ 2drop ] when
     ] catch ;
@@ -150,27 +151,18 @@ USE: hashtables
     pop-d drop ( condition )
     infer-branches ;
 
+\ ifte [ infer-ifte ] "infer" set-word-property
+
 : vtable>list ( [ vtable | rstate ] -- list )
     unswons vector>list [ over cons ] map nip ;
 
-: infer-generic ( -- )
+: infer-dispatch ( -- )
     #! Infer effects for all branches, unify.
     2 ensure-d
     dataflow-drop, pop-d vtable>list
-    >r 1 meta-d get vector-tail* #generic r>
+    >r 1 meta-d get vector-tail* #dispatch r>
+    pop-d drop ( n )
     infer-branches ;
 
-: infer-2generic ( -- )
+\ dispatch [ infer-dispatch ] "infer" set-word-property
-    #! Infer effects for all branches, unify.
+\ dispatch [ 2 | 0 ] "infer-effect" set-word-property
-    3 ensure-d
-    dataflow-drop, pop-d vtable>list
-    >r 2 meta-d get vector-tail* #2generic r>
-    infer-branches ;
-
-\ ifte [ infer-ifte ] "infer" set-word-property
-
-\ generic [ infer-generic ] "infer" set-word-property
-\ generic [ 2 | 0 ] "infer-effect" set-word-property
-
-\ 2generic [ infer-2generic ] "infer" set-word-property
-\ 2generic [ 3 | 0 ] "infer-effect" set-word-property

library/inference/dataflow.factor

@@ -50,8 +50,7 @@ SYMBOL: #call-label
 SYMBOL: #push ( literal )
 
 SYMBOL: #ifte
-SYMBOL: #generic
+SYMBOL: #dispatch
-SYMBOL: #2generic
 
 ! This is purely a marker for values we retain after a
 ! conditional. It does not generate code, but merely alerts the

library/kernel.factor

@@ -50,11 +50,14 @@ USE: vectors
 ! It is quite clumsy, however. A higher-level CLOS-style
 ! 'generic words' system will be built later.
 
+: dispatch ( n vtable -- )
+    vector-nth call ;
+
 : generic ( obj vtable -- )
-    >r dup type r> vector-nth call ;
+    >r dup type r> dispatch ; inline
 
 : 2generic ( n n vtable -- )
-    >r 2dup arithmetic-type r> vector-nth call ;
+    >r 2dup arithmetic-type r> dispatch ; inline
 
 : hashcode ( obj -- hash )
     #! If two objects are =, they must have equal hashcodes.

library/test/dataflow.factor

@@ -63,7 +63,7 @@ USE: generic
 
 [ t ] [
     [ { [ drop ] [ undefined-method ] [ drop ] [ undefined-method ] } generic ] dataflow
-    #generic swap dataflow-contains-op? car [
+    #dispatch swap dataflow-contains-op? car [
         node-param get [
             [ [ node-param get \ undefined-method = ] bind ] some?
         ] some?