VOP cleanups

contrib/units/dimensioned.factor

@@ -3,9 +3,6 @@ USING: kernel prettyprint io sequences words lists vectors inspector math errors
 
 
 IN: units-internal
-: seq-diff ( seq1 seq2 -- seq2-seq1 )
-    [ swap member? not ] subset-with ; flushable
-
 : seq-intersect ( seq1 seq2 -- seq1/\seq2 )
     [ swap member? ] subset-with ; flushable
 

library/collections/sequences-epilogue.factor

@@ -103,6 +103,9 @@ M: object >list ( seq -- list ) dup length 0 rot (>list) ;
     #! Remove duplicates.
     dup dup length <vector> swap [ over adjoin ] each swap like ;
 
+: diff ( seq1 seq2 -- seq2-seq1 )
+    [ swap member? not ] subset-with ; flushable
+
 : append3 ( s1 s2 s3 -- s1+s2+s3 )
     #! Return a new sequence of the same type as s1.
     rot [ [ rot nappend ] keep swap nappend ] immutable ; flushable

library/compiler/amd64/architecture.factor

@@ -13,12 +13,7 @@ USING: assembler compiler-backend kernel sequences ;
     #! Can fixnum operations take immediate operands?
     f ; inline
 
-: vregs ( -- n )
+: vregs { RAX RCX RDX RSI RDI R8 R9 R10 R11 } ; inline
-    #! Number of vregs
-    3 ; inline
-
-M: vreg v>operand ( vreg -- reg )
-    vreg-n { RAX RCX RDX RSI RDI R8 R9 R10 R11 } nth ;
 
 ! FIXME
 M: int-regs fastcall-regs drop 0 ;

library/compiler/amd64/load.factor

@@ -4,7 +4,10 @@ USING: io kernel parser sequences ;
     "/library/compiler/x86/assembler.factor"
     "/library/compiler/amd64/assembler.factor"
     "/library/compiler/amd64/architecture.factor"
+    "/library/compiler/x86/generator.factor"
+    "/library/compiler/x86/slots.factor"
     "/library/compiler/x86/stack.factor"
+    "/library/compiler/amd64/stack.factor"
 ] [
     dup print run-resource
 ] each

library/compiler/amd64/stack.factor

@@ -0,0 +1,9 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: compiler-backend
+USING: arrays assembler compiler kernel ;
+
+: load-indirect ( dest literal -- )
+    #! We cannot use the x86 definition here.
+    0 scratch swap add-literal MOV 0 0 rel-address
+    0 scratch swap 1array MOV ;

library/compiler/architecture.factor

@@ -5,8 +5,7 @@ IN: compiler-backend
 DEFER: fixnum-imm? ( -- ? )
 #! Can fixnum operations take immediate operands?
 
-DEFER: vregs ( -- n )
+DEFER: vregs ( -- regs )
-#! Number of vregs
 
 DEFER: dual-fp/int-regs? ( -- ? )
 #! Should fp parameters to fastcalls be loaded in integer

library/compiler/ppc/architecture.factor

@@ -10,11 +10,7 @@ USING: assembler compiler-backend kernel math ;
     #! Can fixnum operations take immediate operands?
     f ; inline
 
-: vregs ( -- n )
+: vregs { 3 4 5 6 7 8 9 10 } ; inline
-    #! Number of vregs
-    8 ; inline
-
-M: vreg v>operand vreg-n 3 + ;
 
 M: int-regs fastcall-regs drop 8 ;
 M: int-regs reg-class-size drop 4 ;

library/compiler/vops.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: compiler-backend
-USING: arrays errors generic hashtables kernel lists math
+USING: arrays errors generic hashtables kernel kernel-internals
-namespaces parser sequences words ;
+lists math memory namespaces parser sequences words ;
 
 ! The linear IR is the second of the two intermediate
 ! representations used by Factor. It is basically a high-level
@@ -47,6 +47,8 @@ GENERIC: v>operand
 
 M: integer v>operand tag-bits shift ;
 
+M: vreg v>operand vreg-n vregs nth ;
+
 M: f v>operand address ;
 
 ! A virtual operation
@@ -56,7 +58,20 @@ TUPLE: vop inputs outputs label ;
 : set-vop-in ( input vop n -- ) swap vop-inputs set-nth ;
 : vop-out ( vop n -- input ) swap vop-outputs nth ;
 
-: with-vop ( vop quot -- ) [ vop set call ] with-scope ; inline
+: (scratch)
+    vop get dup vop-inputs swap vop-outputs append
+    [ vreg? ] subset [ v>operand ] map vregs diff ;
+
+: scratch ( n -- reg )
+    #! Output a scratch register that is not used by the
+    #! current VOP.
+    \ scratch get nth ;
+
+: with-vop ( vop quot -- )
+    [
+        swap vop set (scratch) \ scratch set call
+    ] with-scope ; inline
+
 : input ( n -- obj ) vop get vop-inputs nth ;
 : input-operand ( n -- n ) input v>operand ;
 : output ( n -- obj ) vop get vop-outputs nth ;

library/compiler/x86/architecture.factor

@@ -13,11 +13,7 @@ USING: assembler compiler-backend kernel sequences ;
     #! Can fixnum operations take immediate operands?
     t ; inline
 
-: vregs ( -- n )
+: vregs { EAX ECX EDX } ; inline
-    #! Number of vregs
-    3 ; inline
-
-M: vreg v>operand vreg-n { EAX ECX EDX } nth ;
 
 ! On x86, parameters are never passed in registers.
 M: int-regs fastcall-regs drop 0 ;

library/compiler/x86/generator.factor

@@ -61,7 +61,7 @@ M: %type generate-node ( vop -- )
     <label> "f" set
     <label> "end" set
     ! Make a copy
-    ECX 0 output-operand MOV
+    0 scratch 0 output-operand MOV
     ! Get the tag
     0 output-operand tag-mask AND
     ! Compare with object tag number (3).
@@ -74,7 +74,7 @@ M: %type generate-node ( vop -- )
     "header" get save-xt
     ! It does store type info in its header
     ! Is the pointer itself equal to 3? Then its F_TYPE (9).
-    ECX object-tag CMP
+    0 scratch object-tag CMP
     "f" get JE
     ! The pointer is not equal to 3. Load the object header.
     0 output-operand ECX object-tag neg 2array MOV

library/compiler/x86/slots.factor

@@ -5,48 +5,48 @@ USING: alien arrays assembler compiler inference kernel
 kernel-internals lists math memory namespaces sequences words ;
 
 M: %slot generate-node ( vop -- )
-    dest/src
+    drop
     ! turn tagged fixnum slot # into an offset, multiple of 4
-    dup 1 SHR
+    0 input-operand 1 SHR
     ! compute slot address in 0 vop-out
-    dupd ADD
+    0 output-operand 0 input-operand ADD
     ! load slot value in 0 vop-out
-    dup 1array MOV ;
+    0 output-operand dup 1array MOV ;
 
 M: %fast-slot generate-node ( vop -- )
-    dup 0 vop-in swap 0 vop-out v>operand tuck >r 2array r>
+    drop
-    swap MOV ;
+    0 output-operand 1 input-operand 0 input 2array MOV ;
 
 : card-offset 1 getenv ;
 
 M: %write-barrier generate-node ( vop -- )
     #! Mark the card pointed to by vreg.
-    0 vop-in v>operand
+    drop
-    dup card-bits SHR
+    0 input-operand dup card-bits SHR
     card-offset 2array card-mark OR
     0 rel-cards ;
 
 M: %set-slot generate-node ( vop -- )
-    dup 2 vop-in v>operand over 1 vop-in v>operand
+    drop
     ! turn tagged fixnum slot # into an offset, multiple of 4
-    over 1 SHR
+    2 input-operand 1 SHR
     ! compute slot address in 1 vop-in
-    dupd ADD
+    2 input-operand 1 input-operand ADD
     ! store new slot value
-    >r 0 vop-in v>operand r> 1array swap MOV ;
+    0 output-operand 1 input-operand 1array MOV ;
 
 M: %fast-set-slot generate-node ( vop -- )
-    dup 2 vop-in over 1 vop-in v>operand
+    drop
-    swap 2array swap 0 vop-in v>operand MOV ;
+    1 input-operand 2 input 2array 0 output-operand MOV ;
 
-: userenv@ ( n -- addr )
+: userenv@ ( n -- addr ) cell * "userenv" f dlsym + ;
-    cell * "userenv" f dlsym + ;
 
 M: %getenv generate-node ( vop -- )
-    dup 0 vop-out v>operand swap 0 vop-in
+    drop
-    [ userenv@ 1array MOV ] keep 0 rel-userenv ;
+    0 output-operand 0 input userenv@ 1array MOV
+    0 input 0 rel-userenv ;
 
 M: %setenv generate-node ( vop -- )
-    dup 1 vop-in
+    drop
-    [ userenv@ 1array swap 0 vop-in v>operand MOV ] keep
+    1 input userenv@ 1array 0 input-operand MOV
-    0 rel-userenv ;
+    1 input rel-userenv ;

library/compiler/x86/stack.factor

@@ -26,6 +26,7 @@ M: %immediate generate-node ( vop -- )
     drop 0 output-operand 0 input address MOV ;
 
 : load-indirect ( dest literal -- )
+    #! This is not valid for AMD64. It is redefined there.
     add-literal 1array MOV 0 0 rel-address ;
 
 M: %indirect generate-node ( vop -- )

library/compiler/xt.factor

@@ -123,6 +123,10 @@ M: fixup-2/2 fixup ( addr fixup -- )
     compiled-offset <relative>
     compiled-offset 4 - <fixup-4> deferred-xt ;
 
+: absolute-4 ( word -- )
+    dup 0 0 rel-word ( FIXME)
+    <absolute> compiled-offset 4 - <fixup-4> deferred-xt ;
+
 : absolute-cell ( word -- )
     dup 0 0 rel-word
     <absolute> compiled-offset cell - <fixup-cell> deferred-xt ;

library/inference/optimizer.factor

@@ -52,13 +52,14 @@ M: node optimize-node* ( node -- t )
     drop t ;
 
 ! #shuffle
+: can-compose? ( shuffle -- ? )
+    dup shuffle-in-d length swap shuffle-in-r length +
+    vregs length <= ;
+
 : compose-shuffle-nodes ( #shuffle #shuffle -- #shuffle/t )
     [ [ node-shuffle ] 2apply compose-shuffle ] keep
-    over shuffle-in-d length pick shuffle-in-r length + vregs > [
+    over can-compose?
-        2drop t
+    [ [ set-node-shuffle ] keep ] [ 2drop t ] if ;
-    ] [
-        [ set-node-shuffle ] keep
-    ] if ;
 
 M: #shuffle optimize-node*  ( node -- node/t )
     dup node-successor dup #shuffle? [