compiler backend code cleanups

library/compiler/basic-blocks.factor

@@ -1,6 +1,10 @@
 IN: compiler-backend
 USING: arrays hashtables kernel lists math namespaces sequences ;
 
+: 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 ;
+
 : (split-blocks) ( n linear -- )
     2dup length = [
         dup like , drop

library/compiler/ppc/alien.factor

@@ -4,7 +4,7 @@ IN: compiler-backend
 USING: alien assembler kernel math ;
 
 M: %alien-invoke generate-node ( vop -- )
-    dup 0 vop-in swap 1 vop-in load-library compile-c-call ;
+    drop 0 input 1 input load-library compile-c-call ;
 
 GENERIC: store-insn
 GENERIC: load-insn
@@ -25,16 +25,14 @@ M: stack-params load-insn ( from to reg-class -- )
     drop >r 0 1 rot stack@ LWZ 0 1 r> stack@ STW ;
 
 M: %unbox generate-node ( vop -- )
-    [ 1 vop-in f compile-c-call ] keep
+    drop
-    [ 2 vop-in return-reg 1 ] keep
+    1 input f compile-c-call
-    [ 0 vop-in ] keep
+    2 input return-reg
-    2 vop-in store-insn ; 
+    1 0 input 2 input store-insn ;
 
 M: %parameter generate-node ( vop -- )
-    [ 0 vop-in ] keep
+    drop 0 input 1 input 2 input load-insn ;
-    [ 1 vop-in ] keep
-    2 vop-in load-insn ;
 
-M: %box generate-node ( vop -- ) 0 vop-in f compile-c-call ;
+M: %box generate-node ( vop -- ) drop 0 input f compile-c-call ;
 
 M: %cleanup generate-node ( vop -- ) drop ;

library/compiler/ppc/fixnum.factor

@@ -4,19 +4,17 @@ IN: compiler-backend
 USING: assembler compiler kernel kernel-internals math
 math-internals memory namespaces words ;
 
-: >3-imm< ( vop -- out1 in2 in1 )
+: >3-imm< ( -- out1 in2 in1 )
-    [ 0 vop-out v>operand ] keep
+    0 output-operand 1 input-operand 0 input ;
-    [ 1 vop-in v>operand ] keep
-    0 vop-in ;
 
-: >3-vop< ( vop -- out1 in1 in2 )
+: >3-vop< ( -- out1 in1 in2 )
     >3-imm< v>operand swap ;
 
-: simple-overflow ( vop inv word -- )
+: simple-overflow ( inv word -- )
     >r >r
     <label> "end" set
     "end" get BNO
-    dup >3-vop< 3dup r> execute
+    >3-vop< 3dup r> execute
     2dup
     dup untag-fixnum
     dup untag-fixnum
@@ -24,22 +22,18 @@ math-internals memory namespaces words ;
     drop
     "s48_long_to_bignum" f compile-c-call
     ! An untagged pointer to the bignum is now in r3; tag it
-    3 swap 0 vop-out v>operand bignum-tag ORI
+    3 0 output-operand bignum-tag ORI
     "end" get save-xt ; inline
 
 M: %fixnum+ generate-node ( vop -- )
-    0 MTXER
+    drop 0 MTXER >3-vop< ADDO. \ SUBF \ ADD simple-overflow ;
-    dup >3-vop< ADDO.
-    \ SUBF \ ADD simple-overflow ;
 
 M: %fixnum- generate-node ( vop -- )
-    0 MTXER
+    drop 0 MTXER >3-vop< SUBFO. \ ADD \ SUBF simple-overflow ;
-    dup >3-vop< SUBFO.
-    \ ADD \ SUBF simple-overflow ;
 
 M: %fixnum* generate-node ( vop -- )
     #! Note that this assumes the output will be in r3.
-    >3-vop< dup dup untag-fixnum
+    drop >3-vop< dup dup untag-fixnum
     0 MTXER
     [ >r >r drop 6 r> r> MULLWO. 3 ] 2keep
     <label> "end" set
@@ -101,25 +95,22 @@ M: %fixnum/mod generate-node ( vop -- )
     6 3 tag-fixnum
     "end" get save-xt ;
 
-M: %fixnum-bitand generate-node ( vop -- )
+M: %fixnum-bitand generate-node ( vop -- ) drop >3-vop< AND ;
-    >3-vop< AND ;
 
-M: %fixnum-bitor generate-node ( vop -- )
+M: %fixnum-bitor generate-node ( vop -- ) drop >3-vop< OR ;
-    >3-vop< OR ;
 
-M: %fixnum-bitxor generate-node ( vop -- )
+M: %fixnum-bitxor generate-node ( vop -- ) drop >3-vop< XOR ;
-    >3-vop< XOR ;
 
 M: %fixnum-bitnot generate-node ( vop -- )
-    dest/src dupd NOT dup untag ;
+    drop dest/src dupd NOT dup untag ;
 
 M: %fixnum<< generate-node ( vop -- )
     ! This has specific register requirements.
+    drop
     <label> "no-overflow" set
     <label> "end" set
-    0 vop-in
     ! check for potential overflow
-    dup shift-add dup 5 LOAD
+    0 input dup shift-add dup 5 LOAD
     4 3 5 ADD
     2 * 1- 5 LOAD
     5 0 4 CMPL
@@ -139,20 +130,16 @@ M: %fixnum<< generate-node ( vop -- )
     "end" get save-xt ;
 
 M: %fixnum>> generate-node ( vop -- )
-    >3-imm< pick >r SRAWI r> dup untag ;
+    drop >3-imm< pick >r SRAWI r> dup untag ;
 
 M: %fixnum-sgn generate-node ( vop -- )
-    dest/src dupd 31 SRAWI dup untag ;
+    drop dest/src 31 SRAWI 0 output-operand dup untag ;
 
-: fixnum-jump ( vop -- label )
+: fixnum-jump ( -- label )
-    [
+    1 input-operand 0 0 input-operand CMP label ;
-        dup 1 vop-in v>operand
-        swap 0 vop-in v>operand
-        0 swap CMP
-    ] keep vop-label ;
 
-M: %jump-fixnum<  generate-node ( vop -- ) fixnum-jump BLT ;
+M: %jump-fixnum<  generate-node ( vop -- ) drop fixnum-jump BLT ;
-M: %jump-fixnum<= generate-node ( vop -- ) fixnum-jump BLE ;
+M: %jump-fixnum<= generate-node ( vop -- ) drop fixnum-jump BLE ;
-M: %jump-fixnum>  generate-node ( vop -- ) fixnum-jump BGT ;
+M: %jump-fixnum>  generate-node ( vop -- ) drop fixnum-jump BGT ;
-M: %jump-fixnum>= generate-node ( vop -- ) fixnum-jump BGE ;
+M: %jump-fixnum>= generate-node ( vop -- ) drop fixnum-jump BGE ;
-M: %jump-eq?      generate-node ( vop -- ) fixnum-jump BEQ ;
+M: %jump-eq?      generate-node ( vop -- ) drop fixnum-jump BEQ ;

library/compiler/ppc/generator.factor

@@ -54,16 +54,16 @@ M: %call generate-node ( vop -- )
     dup primitive? [ word-addr  3 MTCTR  BCTR ] [ B ] if ;
 
 M: %jump generate-node ( vop -- )
-    vop-label  compile-epilogue compile-jump ;
+    drop label  compile-epilogue compile-jump ;
 
 M: %jump-label generate-node ( vop -- )
-    vop-label B ;
+    drop label B ;
 
 M: %jump-t generate-node ( vop -- )
-    dup 0 vop-in v>operand 0 swap f address CMPI vop-label BNE ;
+    drop 0 input-operand 0 swap f address CMPI vop-label BNE ;
 
 M: %return-to generate-node ( vop -- )
-    vop-label 0 3 LOAD32  absolute-16/16
+    drop label 0 3 LOAD32  absolute-16/16
     1 1 stack-increment neg STWU
     3 1 stack-increment lr@ STW ;
 
@@ -73,49 +73,49 @@ M: %return generate-node ( vop -- )
 : untag ( dest src -- ) 0 0 31 tag-bits - RLWINM ;
 
 M: %untag generate-node ( vop -- )
-    dest/src untag ;
+    drop dest/src untag ;
 
 : tag-fixnum ( src dest -- ) tag-bits SLWI ;
 
 : untag-fixnum ( src dest -- ) tag-bits SRAWI ;
 
 M: %dispatch generate-node ( vop -- )
-    0 <vreg> check-src
+    drop
-    3 3 1 SRAWI
+    0 input-operand dup 1 SRAWI
     ! The value 24 is a magic number. It is the length of the
     ! instruction sequence that follows to be generated.
-    compiled-offset 24 + 4 LOAD32  0 1 rel-address
+    compiled-offset 24 + 0 scratch LOAD32  0 1 rel-address
-    3 3 4 ADD
+    0 input-operand dup 0 scratch ADD
-    3 3 0 LWZ
+    0 input-operand dup 0 LWZ
-    3 MTLR
+    0 input-operand MTLR
     BLR ;
 
 M: %type generate-node ( vop -- )
-    0 <vreg> check-src
+    drop
     <label> "f" set
     <label> "end" set
     ! Get the tag
-    3 5 tag-mask ANDI
+    0 input-operand 1 scratch tag-mask ANDI
     ! Tag the tag
-    5 4 tag-fixnum
+    1 scratch 0 scratch tag-fixnum
     ! Compare with object tag number (3).
-    0 5 object-tag CMPI
+    0 1 scratch object-tag CMPI
     ! Jump if the object doesn't store type info in its header
     "end" get BNE
     ! It does store type info in its header
     ! Is the pointer itself equal to 3? Then its F_TYPE (9).
-    0 3 object-tag CMPI
+    0 0 input-operand object-tag CMPI
     "f" get BEQ
     ! The pointer is not equal to 3. Load the object header.
-    4 3 object-tag neg LWZ
+    0 scratch 0 input-operand object-tag neg LWZ
-    4 4 untag
+    0 scratch dup untag
     "end" get B
     "f" get save-xt
     ! The pointer is equal to 3. Load F_TYPE (9).
-    f type tag-bits shift 4 LI
+    f type tag-bits shift 0 scratch LI
     "end" get save-xt
-    3 4 MR ;
+    0 output-operand 0 scratch MR ;
 
 M: %tag generate-node ( vop -- )
-    dup 0 vop-in v>operand swap 0 vop-out v>operand
+    drop dest/src swap tag-mask ANDI
-    [ tag-mask ANDI ] keep dup tag-fixnum ;
+    0 output-operand dup tag-fixnum ;

library/compiler/ppc/slots.factor

@@ -4,57 +4,54 @@ IN: compiler-backend
 USING: alien assembler compiler inference kernel
 kernel-internals lists math memory namespaces sequences words ;
 
-: generate-slot ( vop size quot -- )
+: generate-slot ( size quot -- )
     >r >r dest/src
     ! turn tagged fixnum slot # into an offset, multiple of 4
-    dup dup tag-bits r> - SRAWI
+    0 input-operand dup tag-bits r> - SRAWI
-    ! compute slot address in 0 vop-out
+    ! compute slot address
-    >r dup dup r> ADD
+    0 output-operand dup 0 input-operand ADD
-    ! load slot value in 0 vop-out
+    ! load slot value
-    dup r> call ; inline
+    0 output-operand dup r> call ; inline
 
 M: %slot generate-node ( vop -- )
     cell log2 [ 0 LWZ ] generate-slot ;
 
 M: %fast-slot generate-node ( vop -- )
-    dup 0 vop-out v>operand dup rot 0 vop-in LWZ ;
+    drop 0 output-operand dup 0 input LWZ ;
 
-: generate-set-slot ( vop size quot -- )
+: generate-set-slot ( size quot -- )
-    >r >r dup 2 vop-in v>operand over 1 vop-in v>operand
+    >r >r
     ! turn tagged fixnum slot # into an offset, multiple of 4
-    over dup tag-bits r> - SRAWI
+    2 input-operand dup tag-bits r> - SRAWI
-    ! compute slot address in 1 vop-in
+    ! compute slot address in 1st input
-    over dup rot ADD
+    2 input-operand dup 1 input-operand ADD
     ! store new slot value
-    >r 0 vop-in v>operand r> r> call ; inline
+    >r 0 input-operand r> r> call ; inline
 
 M: %set-slot generate-node ( vop -- )
-    cell log2 [ 0 STW ] generate-set-slot ;
+    drop cell log2 [ 0 STW ] generate-set-slot ;
 
 M: %fast-set-slot generate-node ( vop -- )
-    [ 0 vop-in v>operand ] keep
+    drop 0 input-operand 1 input-operand 2 input STW ;
-    [ 1 vop-in v>operand ] keep
-    2 vop-in STW ;
 
 M: %write-barrier generate-node ( vop -- )
     #! Mark the card pointed to by vreg.
-    #! Uses r6 for storage.
+    drop
-    0 vop-in v>operand
+    0 input-operand card-bits SRAWI
-    dup dup card-bits SRAWI
+    0 input-operand dup 16 ADD
-    dup dup 16 ADD
+    0 scratch 0 input-operand 0 LBZ
-    6 over 0 LBZ
+    0 scratch dup card-mark ORI
-    6 6 card-mark ORI
+    0 scratch 0 input-operand 0 STB ;
-    6 swap 0 STB ;
 
 : string-offset cell 3 * object-tag - ;
 
 M: %char-slot generate-node ( vop -- )
-    dup 1 [ string-offset LHZ ] generate-slot
+    drop 1 [ string-offset LHZ ] generate-slot
-    0 vop-out v>operand dup tag-fixnum ;
+    0 output-operand dup tag-fixnum ;
 
 M: %set-char-slot generate-node ( vop -- )
-    ! untag the new value in 0 vop-in
+    ! untag the new value in 0th input
-    dup 0 vop-in v>operand dup untag-fixnum
+    drop 0 input-operand dup untag-fixnum
     1 [ string-offset STH ] generate-set-slot ;
 
 : userenv ( reg -- )
@@ -62,10 +59,8 @@ M: %set-char-slot generate-node ( vop -- )
     "userenv" f dlsym swap LOAD32 0 1 rel-userenv ;
 
 M: %getenv generate-node ( vop -- )
-    dup 0 vop-out v>operand dup userenv
+    drop 0 output-operand dup dup userenv 0 input cell * LWZ ;
-    dup rot 0 vop-in cell * LWZ ;
 
 M: %setenv generate-node ( vop -- )
-    ! bad! need to formalize scratch register usage
+    drop 0 scratch userenv
-    4 <vreg> v>operand dup userenv >r
+    0 input-operand 0 scratch 1 input cell * STW ;
-    dup 0 vop-in v>operand r> rot 1 vop-in cell * STW ;

library/compiler/ppc/stack.factor

@@ -4,28 +4,26 @@ IN: compiler-backend
 USING: assembler compiler errors kernel kernel-internals math
 memory words ;
 
-GENERIC: loc>operand
+M: ds-loc v>operand ds-loc-n cell * neg 14 swap ;
-
+M: cs-loc v>operand cs-loc-n cell * neg 15 swap ;
-M: ds-loc loc>operand ds-loc-n cell * neg 14 swap ;
-M: cs-loc loc>operand cs-loc-n cell * neg 15 swap ;
 
 M: %immediate generate-node ( vop -- )
-    dup 0 vop-in address swap 0 vop-out v>operand LOAD ;
+    drop 0 input address 0 output-operand LOAD ;
 
 : load-indirect ( dest literal -- )
     add-literal over LOAD32 0 1 rel-address dup 0 LWZ ;
 
 M: %indirect generate-node ( vop -- )
-    dup 0 vop-out v>operand swap 0 vop-in load-indirect ;
+    drop 0 output-operand 0 input load-indirect ;
 
 M: %peek generate-node ( vop -- )
-    dup 0 vop-out v>operand swap 0 vop-in loc>operand LWZ ;
+    drop dest/src LWZ ;
 
 M: %replace generate-node ( vop -- )
-    dup 0 vop-in v>operand swap 0 vop-out loc>operand STW ;
+    drop dest/src swap STW ;
 
 M: %inc-d generate-node ( vop -- )
-    14 14 rot 0 vop-in cell * ADDI ;
+    drop 14 14 0 input cell * ADDI ;
 
 M: %inc-r generate-node ( vop -- )
-    15 15 rot 0 vop-in cell * ADDI ;
+    drop 15 15 0 input cell * ADDI ;

library/compiler/vops.factor

@@ -54,10 +54,6 @@ 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 ;
-
 : (scratch)
     vop get dup vop-inputs swap vop-outputs append
     [ vreg? ] subset [ v>operand ] map vregs diff ;
@@ -80,6 +76,7 @@ TUPLE: vop inputs outputs label ;
 
 GENERIC: basic-block? ( vop -- ? )
 M: vop basic-block? drop f ;
+
 ! simplifies some code
 M: f basic-block? drop f ;
 
@@ -104,12 +101,6 @@ 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 ;
@@ -370,7 +361,6 @@ M: %getenv basic-block? drop t ;
 TUPLE: %setenv ;
 C: %setenv make-vop ;
 : %setenv 2-in-vop <%setenv> ;
-M: %setenv basic-block? drop t ;
 
 ! alien operations
 TUPLE: %parameters ;

library/compiler/x86/alien.factor

@@ -6,7 +6,7 @@ kernel-internals lists math memory namespaces words ;
 
 M: %alien-invoke generate-node
     #! call a C function.
-    dup 0 vop-in swap 1 vop-in load-library compile-c-call ;
+    drop 0 input 1 input load-library compile-c-call ;
 
 M: %parameter generate-node
     #! x86 does not pass parameters in registers
@@ -24,12 +24,13 @@ M: float-regs push-reg
     4 = [ FSTPS ] [ FSTPL ] if ;
 
 M: %unbox generate-node
-    dup 1 vop-in f compile-c-call  2 vop-in push-reg ;
+    drop 1 input f compile-c-call  2 input push-reg ;
 
 M: %box generate-node
-    dup 1 vop-in push-reg
+    drop
-    dup 0 vop-in f compile-c-call
+    1 input push-reg
-    1 vop-in ESP swap reg-size ADD ;
+    0 input f compile-c-call
+    ESP 1 input reg-size ADD ;
 
 M: %cleanup generate-node
-    0 vop-in dup 0 = [ drop ] [ ESP swap ADD ] if ;
+    drop 0 input dup 0 = [ drop ] [ ESP swap ADD ] if ;

library/compiler/x86/slots.factor

@@ -8,9 +8,9 @@ M: %slot generate-node ( vop -- )
     drop
     ! turn tagged fixnum slot # into an offset, multiple of 4
     0 input-operand fixnum>slot@
-    ! compute slot address in 0 vop-out
+    ! compute slot address
     dest/src ADD
-    ! load slot value in 0 vop-out
+    ! load slot value
     0 output-operand dup 1array MOV ;
 
 M: %fast-slot generate-node ( vop -- )
@@ -34,7 +34,7 @@ M: %set-slot generate-node ( vop -- )
     drop
     ! turn tagged fixnum slot # into an offset
     2 input-operand fixnum>slot@
-    ! compute slot address in 2 vop-in
+    ! compute slot address
     2 input-operand 1 input-operand ADD
     ! store new slot value
     2 input-operand 1array 0 input-operand MOV ;