compiler backend code cleanups
Slava Pestov
parent
c5888330d6
commit
408939d92d
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[ 2 vop-in return-reg 1 ] keep
|
||||
[ 0 vop-in ] keep
|
||||
2 vop-in store-insn ;
|
||||
drop
|
||||
1 input f compile-c-call
|
||||
2 input return-reg
|
||||
1 0 input 2 input store-insn ;
|
||||
|
||||
M: %parameter generate-node ( vop -- )
|
||||
[ 0 vop-in ] keep
|
||||
[ 1 vop-in ] keep
|
||||
2 vop-in load-insn ;
|
||||
drop 0 input 1 input 2 input 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 ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
[ 0 vop-out v>operand ] keep
|
||||
[ 1 vop-in v>operand ] keep
|
||||
0 vop-in ;
|
||||
: >3-imm< ( -- out1 in2 in1 )
|
||||
0 output-operand 1 input-operand 0 input ;
|
||||
|
||||
: >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
|
||||
dup >3-vop< ADDO.
|
||||
\ SUBF \ ADD simple-overflow ;
|
||||
drop 0 MTXER >3-vop< ADDO. \ SUBF \ ADD simple-overflow ;
|
||||
|
||||
M: %fixnum- generate-node ( vop -- )
|
||||
0 MTXER
|
||||
dup >3-vop< SUBFO.
|
||||
\ ADD \ SUBF simple-overflow ;
|
||||
drop 0 MTXER >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 -- )
|
||||
>3-vop< AND ;
|
||||
M: %fixnum-bitand generate-node ( vop -- ) drop >3-vop< AND ;
|
||||
|
||||
M: %fixnum-bitor generate-node ( vop -- )
|
||||
>3-vop< OR ;
|
||||
M: %fixnum-bitor generate-node ( vop -- ) drop >3-vop< OR ;
|
||||
|
||||
M: %fixnum-bitxor generate-node ( vop -- )
|
||||
>3-vop< XOR ;
|
||||
M: %fixnum-bitxor generate-node ( vop -- ) drop >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 )
|
||||
[
|
||||
dup 1 vop-in v>operand
|
||||
swap 0 vop-in v>operand
|
||||
0 swap CMP
|
||||
] keep vop-label ;
|
||||
: fixnum-jump ( -- label )
|
||||
1 input-operand 0 0 input-operand CMP label ;
|
||||
|
||||
M: %jump-fixnum< generate-node ( vop -- ) fixnum-jump BLT ;
|
||||
M: %jump-fixnum<= generate-node ( vop -- ) fixnum-jump BLE ;
|
||||
M: %jump-fixnum> generate-node ( vop -- ) fixnum-jump BGT ;
|
||||
M: %jump-fixnum>= generate-node ( vop -- ) fixnum-jump BGE ;
|
||||
M: %jump-eq? generate-node ( vop -- ) fixnum-jump BEQ ;
|
||||
M: %jump-fixnum< generate-node ( vop -- ) drop fixnum-jump BLT ;
|
||||
M: %jump-fixnum<= generate-node ( vop -- ) drop fixnum-jump BLE ;
|
||||
M: %jump-fixnum> generate-node ( vop -- ) drop fixnum-jump BGT ;
|
||||
M: %jump-fixnum>= generate-node ( vop -- ) drop fixnum-jump BGE ;
|
||||
M: %jump-eq? generate-node ( vop -- ) drop fixnum-jump BEQ ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
3 3 1 SRAWI
|
||||
drop
|
||||
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
|
||||
3 3 4 ADD
|
||||
3 3 0 LWZ
|
||||
3 MTLR
|
||||
compiled-offset 24 + 0 scratch LOAD32 0 1 rel-address
|
||||
0 input-operand dup 0 scratch ADD
|
||||
0 input-operand dup 0 LWZ
|
||||
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
|
||||
4 4 untag
|
||||
0 scratch 0 input-operand object-tag neg LWZ
|
||||
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
|
||||
[ tag-mask ANDI ] keep dup tag-fixnum ;
|
||||
drop dest/src swap tag-mask ANDI
|
||||
0 output-operand dup tag-fixnum ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
! compute slot address in 0 vop-out
|
||||
>r dup dup r> ADD
|
||||
! load slot value in 0 vop-out
|
||||
dup r> call ; inline
|
||||
0 input-operand dup tag-bits r> - SRAWI
|
||||
! compute slot address
|
||||
0 output-operand dup 0 input-operand ADD
|
||||
! load slot value
|
||||
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 -- )
|
||||
>r >r dup 2 vop-in v>operand over 1 vop-in v>operand
|
||||
: generate-set-slot ( size quot -- )
|
||||
>r >r
|
||||
! turn tagged fixnum slot # into an offset, multiple of 4
|
||||
over dup tag-bits r> - SRAWI
|
||||
! compute slot address in 1 vop-in
|
||||
over dup rot ADD
|
||||
2 input-operand dup tag-bits r> - SRAWI
|
||||
! compute slot address in 1st input
|
||||
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
|
||||
[ 1 vop-in v>operand ] keep
|
||||
2 vop-in STW ;
|
||||
drop 0 input-operand 1 input-operand 2 input STW ;
|
||||
|
||||
M: %write-barrier generate-node ( vop -- )
|
||||
#! Mark the card pointed to by vreg.
|
||||
#! Uses r6 for storage.
|
||||
0 vop-in v>operand
|
||||
dup dup card-bits SRAWI
|
||||
dup dup 16 ADD
|
||||
6 over 0 LBZ
|
||||
6 6 card-mark ORI
|
||||
6 swap 0 STB ;
|
||||
drop
|
||||
0 input-operand card-bits SRAWI
|
||||
0 input-operand dup 16 ADD
|
||||
0 scratch 0 input-operand 0 LBZ
|
||||
0 scratch dup card-mark ORI
|
||||
0 scratch 0 input-operand 0 STB ;
|
||||
|
||||
: string-offset cell 3 * object-tag - ;
|
||||
|
||||
M: %char-slot generate-node ( vop -- )
|
||||
dup 1 [ string-offset LHZ ] generate-slot
|
||||
0 vop-out v>operand dup tag-fixnum ;
|
||||
drop 1 [ string-offset LHZ ] generate-slot
|
||||
0 output-operand dup tag-fixnum ;
|
||||
|
||||
M: %set-char-slot generate-node ( vop -- )
|
||||
! untag the new value in 0 vop-in
|
||||
dup 0 vop-in v>operand dup untag-fixnum
|
||||
! untag the new value in 0th input
|
||||
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
|
||||
dup rot 0 vop-in cell * LWZ ;
|
||||
drop 0 output-operand dup dup userenv 0 input cell * LWZ ;
|
||||
|
||||
M: %setenv generate-node ( vop -- )
|
||||
! bad! need to formalize scratch register usage
|
||||
4 <vreg> v>operand dup userenv >r
|
||||
dup 0 vop-in v>operand r> rot 1 vop-in cell * STW ;
|
||||
drop 0 scratch userenv
|
||||
0 input-operand 0 scratch 1 input cell * STW ;
|
||||
|
|
|
|||
|
|
@ -4,28 +4,26 @@ IN: compiler-backend
|
|||
USING: assembler compiler errors kernel kernel-internals math
|
||||
memory words ;
|
||||
|
||||
GENERIC: loc>operand
|
||||
|
||||
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: ds-loc v>operand ds-loc-n cell * neg 14 swap ;
|
||||
M: cs-loc v>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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
dup 0 vop-in f compile-c-call
|
||||
1 vop-in ESP swap reg-size ADD ;
|
||||
drop
|
||||
1 input push-reg
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue