steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

some VOP refactoring

cvs
Slava Pestov 2005-12-05 00:56:42 +00:00
parent b165769d46
commit 0c68096656
7 changed files with 66 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
library/compiler/generator.factor
View File

@ -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 ;

5
library/compiler/linearizer.factor
View File

@ -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 )

31
library/compiler/vops.factor
View File

@ -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> ;

19
library/compiler/x86/assembler.factor
View File

@ -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 = ;

52
library/compiler/x86/generator.factor
View File

@ -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
0 vop-in v>operand dup tag-mask AND
tag-bits SHL ;
drop
0 input-operand tag-mask AND
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 ;

20
library/compiler/x86/stack.factor
View File

@ -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 loc>operand cs-loc-n cs-reg reg-stack ;
M: cs-loc v>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 ;

7
library/compiler/xt.factor
View File

@ -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 off ;
compiled-xts get [ swap set-word-xt ] hash-each ;
: 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