some VOP refactoring

library/compiler/generator.factor

@@ -19,7 +19,7 @@ GENERIC: generate-node ( vop -- )
     compiled-offset >r
     compile-aligned
     swap save-xt
-    [ [ generate-node ] each ] each
+    [ [ dup [ generate-node ] with-vop ] each ] each
     compile-aligned
     compiled-offset r> - ;
 
@@ -66,12 +66,6 @@ M: %target generate-node
 
 M: %parameters generate-node ( vop -- ) drop ;
 
-GENERIC: v>operand
-
-M: integer v>operand tag-bits shift ;
-
-M: f v>operand address ;
-
 : dest/src ( vop -- dest src )
     dup 0 vop-out v>operand swap 0 vop-in v>operand ;
 

library/compiler/linearizer.factor

@@ -4,6 +4,11 @@ IN: compiler-frontend
 USING: arrays compiler-backend errors generic inference kernel
 lists math namespaces prettyprint sequences strings words ;
 
+: in-1 0 0 %peek-d , ;
+: in-2 0 1 %peek-d ,  1 0 %peek-d , ;
+: in-3 0 2 %peek-d ,  1 1 %peek-d ,  2 0 %peek-d , ;
+: out-1 T{ vreg f 0 } 0 %replace-d , ;
+
 GENERIC: linearize* ( node -- )
 
 : linearize ( dataflow -- linear )

library/compiler/vops.factor

@@ -43,13 +43,25 @@ TUPLE: cs-loc n ;
 ! A pseudo-register class for parameters spilled on the stack
 TUPLE: stack-params ;
 
+GENERIC: v>operand
+
+M: integer v>operand tag-bits shift ;
+
+M: f v>operand address ;
+
 ! A virtual operation
 TUPLE: vop inputs outputs label ;
 
 : vop-in ( vop n -- input ) swap vop-inputs nth ;
 : set-vop-in ( input vop n -- ) swap vop-inputs set-nth ;
 : vop-out ( vop n -- input ) swap vop-outputs nth ;
-: set-vop-out ( input vop n -- ) swap vop-outputs set-nth ;
+
+: with-vop ( vop quot -- ) [ vop 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 ;
+: output-operand ( n -- n ) output v>operand ;
+: label ( -- label ) vop get vop-label ;
 
 GENERIC: basic-block? ( vop -- ? )
 M: vop basic-block? drop f ;
@@ -77,6 +89,12 @@ M: vop stack-reserve drop 0 ;
 : 2-vop ( in dest) [ 2array ] keep 1array f ;
 : 3-vop ( in1 in2 dest) >r 2array r> 1array f ;
 
+: check-dest ( vop reg -- )
+    swap 0 vop-out = [ "bad VOP destination" throw ] unless ;
+
+: check-src ( vop reg -- )
+    swap 0 vop-in = [ "bad VOP source" throw ] unless ;
+
 ! miscellanea
 TUPLE: %prologue ;
 C: %prologue make-vop ;
@@ -179,11 +197,6 @@ C: %immediate make-vop ;
 
 M: %immediate basic-block? drop t ;
 
-: in-1 0 0 %peek-d , ;
-: in-2 0 1 %peek-d ,  1 0 %peek-d , ;
-: in-3 0 2 %peek-d ,  1 1 %peek-d ,  2 0 %peek-d , ;
-: out-1 T{ vreg f 0 } 0 %replace-d , ;
-
 ! indirect load of a literal through a table
 TUPLE: %indirect ;
 C: %indirect make-vop ;
@@ -334,12 +347,6 @@ C: %tag make-vop ;
 : %tag ( vreg ) <vreg> dest-vop <%tag> ;
 M: %tag basic-block? drop t ;
 
-: check-dest ( vop reg -- )
-    swap 0 vop-out = [ "bad VOP destination" throw ] unless ;
-
-: check-src ( vop reg -- )
-    swap 0 vop-in = [ "bad VOP source" throw ] unless ;
-
 TUPLE: %getenv ;
 C: %getenv make-vop ;
 : %getenv swap src/dest-vop <%getenv> ;

library/compiler/x86/assembler.factor

@@ -47,25 +47,6 @@ REGISTER: EBP 5 32
 REGISTER: ESI 6 32
 REGISTER: EDI 7 32
 
-! AMD64 registers
-REGISTER: RAX 0 64
-REGISTER: RCX 1 64
-REGISTER: RDX 2 64
-REGISTER: RBX 3 64
-REGISTER: RSP 4 64
-REGISTER: RBP 5 64
-REGISTER: RSI 6 64
-REGISTER: RDI 7 64
-
-REGISTER: R8 8 64
-REGISTER: R9 9 64
-REGISTER: R10 10 64
-REGISTER: R11 11 64
-REGISTER: R12 12 64
-REGISTER: R13 13 64
-REGISTER: R14 14 64
-REGISTER: R15 15 64
-
 PREDICATE: word register "register" word-prop ;
 
 PREDICATE: register register-32 "register-size" word-prop 32 = ;

library/compiler/x86/generator.factor

@@ -13,22 +13,26 @@ M: %prologue generate-node drop ;
 : compile-c-call ( symbol dll -- ) [ CALL ] compile-dlsym ;
 
 M: %call generate-node ( vop -- )
-    vop-label dup postpone-word CALL ;
+    drop label dup postpone-word CALL ;
 
 M: %call-label generate-node ( vop -- )
-    vop-label CALL ;
+    drop label CALL ;
 
 M: %jump generate-node ( vop -- )
-    vop-label dup postpone-word JMP ;
+    drop label dup postpone-word JMP ;
 
 M: %jump-label generate-node ( vop -- )
-    vop-label JMP ;
+    drop label JMP ;
 
 M: %jump-t generate-node ( vop -- )
-    dup 0 vop-in v>operand f address CMP vop-label JNE ;
+    drop
+    ! Compare input with f
+    0 input-operand f address CMP
+    ! If not equal, jump
+    label JNE ;
 
 M: %return-to generate-node ( vop -- )
-    0 PUSH vop-label absolute ;
+    drop 0 PUSH label absolute-4 ;
 
 M: %return generate-node ( vop -- )
     drop RET ;
@@ -37,34 +41,35 @@ M: %dispatch generate-node ( vop -- )
     #! Compile a piece of code that jumps to an offset in a
     #! jump table indexed by the fixnum at the top of the stack.
     #! The jump table must immediately follow this macro.
-    0 vop-in v>operand
+    <label> "end" set
+    drop
     ! Untag and multiply by 4 to get a jump table offset
-    dup tag-bits 2 - SHR
+    0 input-operand tag-bits 2 - SHR
     ! Add to jump table base
-    dup HEX: ffff ADD  just-compiled >r 0 0 rel-address
+    0 input-operand HEX: ffff ADD "end" get absolute-4
     ! Jump to jump table entry
-    1array JMP
+    0 input-operand 1array JMP
     ! Align for better performance
     compile-aligned
     ! Fix up jump table pointer
-    compiled-offset r> set-compiled-cell ( fixup -- ) ;
+    "end" get save-xt ;
 
 M: %type generate-node ( vop -- )
     #! Intrinstic version of type primitive.
+    drop
     <label> "header" set
     <label> "f" set
     <label> "end" set
-    0 vop-out v>operand
     ! Make a copy
-    ECX over MOV
+    ECX 0 output-operand MOV
     ! Get the tag
-    dup tag-mask AND
+    0 output-operand tag-mask AND
     ! Compare with object tag number (3).
-    dup object-tag CMP
+    0 output-operand object-tag CMP
     ! Jump if the object doesn't store type info in its header
     "header" get JE
     ! It doesn't store type info in its header
-    dup tag-bits SHL
+    0 output-operand tag-bits SHL
     "end" get JMP
     "header" get save-xt
     ! It does store type info in its header
@@ -72,19 +77,20 @@ M: %type generate-node ( vop -- )
     ECX object-tag CMP
     "f" get JE
     ! The pointer is not equal to 3. Load the object header.
-    dup ECX object-tag neg 2array MOV
+    0 output-operand ECX object-tag neg 2array MOV
     ! Mask off header tag, making a fixnum.
-    dup object-tag XOR
+    0 output-operand object-tag XOR
     "end" get JMP
     "f" get save-xt
     ! The pointer is equal to 3. Load F_TYPE (9).
-    f type tag-bits shift MOV
+    0 output-operand f type tag-bits shift MOV
     "end" get save-xt ;
 
 M: %tag generate-node ( vop -- )
-    dup dup 0 vop-in check-dest
+    drop
-    0 vop-in v>operand dup tag-mask AND
+    0 input-operand tag-mask AND
-    tag-bits SHL ;
+    0 input-operand tag-bits SHL ;
 
 M: %untag generate-node ( vop -- )
-    0 vop-out v>operand tag-mask bitnot AND ;
+    drop
+    0 output-operand tag-mask bitnot AND ;

library/compiler/x86/stack.factor

@@ -6,30 +6,28 @@ kernel-internals lists math memory sequences words ;
 
 : reg-stack ( n reg -- op ) swap cell * neg 2array ;
 
-GENERIC: loc>operand
+M: ds-loc v>operand ds-loc-n ds-reg reg-stack ;
 
-M: ds-loc loc>operand ds-loc-n ds-reg reg-stack ;
+M: cs-loc v>operand cs-loc-n cs-reg reg-stack ;
-
-M: cs-loc loc>operand cs-loc-n cs-reg reg-stack ;
 
 M: %peek generate-node ( vop -- )
-    dup 0 vop-out v>operand swap 0 vop-in loc>operand MOV ;
+    drop 0 output-operand 0 input-operand MOV ;
 
 M: %replace generate-node ( vop -- )
-    dup 0 vop-out loc>operand swap 0 vop-in v>operand MOV ;
+    drop 0 output-operand 0 input-operand MOV ;
 
-: (%inc) swap 0 vop-in cell * dup 0 > [ ADD ] [ neg SUB ] if ;
+: (%inc) 0 input cell * dup 0 > [ ADD ] [ neg SUB ] if ;
 
-M: %inc-d generate-node ( vop -- ) ds-reg (%inc) ;
+M: %inc-d generate-node ( vop -- ) drop ds-reg (%inc) ;
 
-M: %inc-r generate-node ( vop -- ) cs-reg (%inc) ;
+M: %inc-r generate-node ( vop -- ) drop cs-reg (%inc) ;
 
 M: %immediate generate-node ( vop -- )
-    dup 0 vop-out v>operand swap 0 vop-in address MOV ;
+    drop 0 output-operand 0 input address MOV ;
 
 : load-indirect ( dest literal -- )
     add-literal 1array MOV 0 0 rel-address ;
 
 M: %indirect generate-node ( vop -- )
     #! indirect load of a literal through a table
-    dup 0 vop-out v>operand swap 0 vop-in load-indirect ;
+    drop 0 output-operand 0 input load-indirect ;

library/compiler/xt.factor

@@ -17,8 +17,7 @@ SYMBOL: compiled-xts
 : commit-xts ( -- )
     #! We must flush the instruction cache on PowerPC.
     flush-icache
-    compiled-xts get [ swap set-word-xt ] hash-each
+    compiled-xts get [ swap set-word-xt ] hash-each ;
-    compiled-xts off ;
 
 : compiled-xt ( word -- xt )
     dup compiled-xts get hash [ ] [ word-xt ] ?if ;
@@ -140,11 +139,11 @@ SYMBOL: compile-words
     [ drop t ] [ compiled-xts get hash ] if ;
 
 : fixup-xts ( -- )
-    deferred-xts get [ fixup ] each  deferred-xts off ;
+    deferred-xts get [ dup resolve swap fixup ] each ;
 
 : with-compiler ( quot -- )
     [
-        V{ } deferred-xts set
+        V{ } clone deferred-xts set
         H{ } clone compiled-xts set
         V{ } clone compile-words set
         call