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

factor: Rename all #foo words except # so # can be a sigil.

modern-harvey3-triple
Doug Coleman 2018-08-10 13:04:49 -05:00
parent 24d266c1f1
commit 4bcae2590c
296 changed files with 5530 additions and 5530 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
basis/bitstreams/bitstreams.factor
View File

@ -7,11 +7,11 @@ IN: bitstreams
TUPLE: widthed
{ bits integer read-only }
{ #bits integer read-only } ;
{ n-bits integer read-only } ;
ERROR: invalid-widthed bits #bits ;
ERROR: invalid-widthed bits n-bits ;
: check-widthed ( bits #bits -- bits #bits )
: check-widthed ( bits n-bits -- bits n-bits )
2dup {
[ nip 0 < ]
[ { [ nip 0 = ] [ drop 0 = not ] } 2&& ]
@ -22,7 +22,7 @@ ERROR: invalid-widthed bits #bits ;
]
} 2|| [ invalid-widthed ] when ;
: <widthed> ( bits #bits -- widthed )
: <widthed> ( bits n-bits -- widthed )
check-widthed
widthed boa ;
@ -88,20 +88,20 @@ GENERIC: poke ( value n bitstream -- )
ERROR: not-enough-widthed-bits widthed n ;
: check-widthed-bits ( widthed n -- widthed n )
2dup { [ nip 0 < ] [ [ #bits>> ] dip < ] } 2||
2dup { [ nip 0 < ] [ [ n-bits>> ] dip < ] } 2||
[ not-enough-widthed-bits ] when ;
: widthed-bits ( widthed n -- bits )
check-widthed-bits
[ [ bits>> ] [ #bits>> ] bi ] dip
[ [ bits>> ] [ n-bits>> ] bi ] dip
[ - neg shift ] keep <widthed> ;
: split-widthed ( widthed n -- widthed1 widthed2 )
2dup [ #bits>> ] dip < [
2dup [ n-bits>> ] dip < [
drop zero-widthed
] [
[ widthed-bits ]
[ [ [ bits>> ] [ #bits>> ] bi ] dip - [ bits ] keep <widthed> ] 2bi
[ [ [ bits>> ] [ n-bits>> ] bi ] dip - [ bits ] keep <widthed> ] 2bi
] if ;
: widthed>bytes ( widthed -- bytes widthed )
@ -110,20 +110,20 @@ ERROR: not-enough-widthed-bits widthed n ;
:: |widthed ( widthed1 widthed2 -- widthed3 )
widthed1 bits>> :> bits1
widthed1 #bits>> :> #bits1
widthed1 n-bits>> :> n-bits1
widthed2 bits>> :> bits2
widthed2 #bits>> :> #bits2
bits1 #bits2 shift bits2 bitor
#bits1 #bits2 + <widthed> ;
widthed2 n-bits>> :> n-bits2
bits1 n-bits2 shift bits2 bitor
n-bits1 n-bits2 + <widthed> ;
PRIVATE>
M:: lsb0-bit-writer poke ( value n bs -- )
value n <widthed> :> widthed
widthed
bs widthed>> #bits>> 8 swap - split-widthed :> ( byte remainder )
bs widthed>> n-bits>> 8 swap - split-widthed :> ( byte remainder )
byte bs widthed>> |widthed :> new-byte
new-byte #bits>> 8 = [
new-byte n-bits>> 8 = [
new-byte bits>> bs bytes>> push
zero-widthed bs widthed<<
remainder widthed>bytes
@ -139,7 +139,7 @@ M:: lsb0-bit-writer poke ( value n bs -- )
ERROR: not-enough-bits n bit-reader ;
: #bits>#bytes ( #bits -- #bytes )
: n-bits>n-bytes ( n-bits -- n-bytes )
8 /mod 0 = [ 1 + ] unless ; inline
:: subseq>bits-le ( bignum n bs -- bits )
@ -151,9 +151,9 @@ ERROR: not-enough-bits n bit-reader ;
neg shift n bits ;
:: adjust-bits ( n bs -- )
n 8 /mod :> ( #bytes #bits )
bs [ #bytes + ] change-byte-pos
bit-pos>> #bits + dup 8 >= [
n 8 /mod :> ( n-bytes n-bits )
bs [ n-bytes + ] change-byte-pos
bit-pos>> n-bits + dup 8 >= [
8 - bs bit-pos<<
bs [ 1 + ] change-byte-pos drop
] [
@ -162,7 +162,7 @@ ERROR: not-enough-bits n bit-reader ;
:: (peek) ( n bs endian> subseq-endian -- bits )
n bs enough-bits? [ n bs not-enough-bits ] unless
bs [ byte-pos>> ] [ bit-pos>> n + ] bi #bits>#bytes dupd +
bs [ byte-pos>> ] [ bit-pos>> n + ] bi n-bits>n-bytes dupd +
bs bytes>> subseq endian> execute( seq -- x )
n bs subseq-endian execute( bignum n bs -- bits ) ;
@ -173,7 +173,7 @@ M: msb0-bit-reader peek ( n bs -- bits )
\ be> \ subseq>bits-be (peek) ;
:: bit-writer-bytes ( writer -- bytes )
writer widthed>> #bits>> :> n
writer widthed>> n-bits>> :> n
n 0 = [
writer widthed>> bits>> 8 n - shift
writer bytes>> push

2
basis/combinators/smart/smart.factor
View File

@ -24,7 +24,7 @@ IDENTITY-MEMO: inputs/outputs ( quot -- in out )
\ inputs/outputs [
peek-d
infer-known [
[ pop-d 1array #drop, ]
[ pop-d 1array drop#, ]
[ [ in>> ] [ out>> ] bi [ length apply-object ] bi@ ] bi*
] [
\ inputs/outputs dup required-stack-effect apply-word/effect

2
basis/compiler/cfg/alias-analysis/alias-analysis-docs.factor
View File

@ -3,7 +3,7 @@ IN: compiler.cfg.alias-analysis
HELP: useless-compare?
{ $values
{ "insn" "a " { $link ##compare } " instruction" }
{ "insn" "a " { $link compare## } " instruction" }
{ "?" boolean }
}
{ $description "Checks if the comparison instruction is required." } ;

468
basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
View File

@ -12,168 +12,168 @@ IN: compiler.cfg.alias-analysis.tests
! Redundant load elimination
{
V{
T{ ##peek f 0 d: 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##copy f 2 1 any-rep }
T{ peek## f 0 d: 0 }
T{ slot-imm## f 1 0 1 0 }
T{ copy## f 2 1 any-rep }
}
} [
V{
T{ ##peek f 0 d: 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##slot-imm f 2 0 1 0 }
T{ peek## f 0 d: 0 }
T{ slot-imm## f 1 0 1 0 }
T{ slot-imm## f 2 0 1 0 }
} test-alias-analysis
] unit-test
! Store-load forwarding
{
V{
T{ ##peek f 0 d: 0 }
T{ ##peek f 1 d: 1 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##copy f 2 1 any-rep }
T{ peek## f 0 d: 0 }
T{ peek## f 1 d: 1 }
T{ set-slot-imm## f 1 0 1 0 }
T{ copy## f 2 1 any-rep }
}
} [
V{
T{ ##peek f 0 d: 0 }
T{ ##peek f 1 d: 1 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##slot-imm f 2 0 1 0 }
T{ peek## f 0 d: 0 }
T{ peek## f 1 d: 1 }
T{ set-slot-imm## f 1 0 1 0 }
T{ slot-imm## f 2 0 1 0 }
} test-alias-analysis
] unit-test
! Dead store elimination
{
V{
T{ ##peek f 0 d: 0 }
T{ ##peek f 1 d: 1 }
T{ ##peek f 2 d: 2 }
T{ ##set-slot-imm f 2 0 1 0 }
T{ peek## f 0 d: 0 }
T{ peek## f 1 d: 1 }
T{ peek## f 2 d: 2 }
T{ set-slot-imm## f 2 0 1 0 }
}
} [
V{
T{ ##peek f 0 d: 0 }
T{ ##peek f 1 d: 1 }
T{ ##peek f 2 d: 2 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##set-slot-imm f 2 0 1 0 }
T{ peek## f 0 d: 0 }
T{ peek## f 1 d: 1 }
T{ peek## f 2 d: 2 }
T{ set-slot-imm## f 1 0 1 0 }
T{ set-slot-imm## f 2 0 1 0 }
} test-alias-analysis
] unit-test
{
V{
T{ ##peek f 0 d: 0 }
T{ ##peek f 1 d: 1 }
T{ ##peek f 2 d: 2 }
T{ ##peek f 3 d: 3 }
T{ ##set-slot-imm f 3 0 1 0 }
T{ peek## f 0 d: 0 }
T{ peek## f 1 d: 1 }
T{ peek## f 2 d: 2 }
T{ peek## f 3 d: 3 }
T{ set-slot-imm## f 3 0 1 0 }
}
} [
V{
T{ ##peek f 0 d: 0 }
T{ ##peek f 1 d: 1 }
T{ ##peek f 2 d: 2 }
T{ ##peek f 3 d: 3 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##set-slot-imm f 2 0 1 0 }
T{ ##set-slot-imm f 3 0 1 0 }
T{ peek## f 0 d: 0 }
T{ peek## f 1 d: 1 }
T{ peek## f 2 d: 2 }
T{ peek## f 3 d: 3 }
T{ set-slot-imm## f 1 0 1 0 }
T{ set-slot-imm## f 2 0 1 0 }
T{ set-slot-imm## f 3 0 1 0 }
} test-alias-analysis
] unit-test
! Redundant store elimination
{
V{
T{ ##peek f 0 d: 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ peek## f 0 d: 0 }
T{ slot-imm## f 1 0 1 0 }
}
} [
V{
T{ ##peek f 0 d: 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ peek## f 0 d: 0 }
T{ slot-imm## f 1 0 1 0 }
T{ set-slot-imm## f 1 0 1 0 }
} test-alias-analysis
] unit-test
{
V{
T{ ##peek f 0 d: 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##copy f 2 1 any-rep }
T{ peek## f 0 d: 0 }
T{ slot-imm## f 1 0 1 0 }
T{ copy## f 2 1 any-rep }
}
} [
V{
T{ ##peek f 0 d: 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##copy f 2 1 any-rep }
T{ ##set-slot-imm f 2 0 1 0 }
T{ peek## f 0 d: 0 }
T{ slot-imm## f 1 0 1 0 }
T{ copy## f 2 1 any-rep }
T{ set-slot-imm## f 2 0 1 0 }
} test-alias-analysis
] unit-test
! Not a redundant load
{
V{
T{ ##peek f 0 d: 0 }
T{ ##peek f 1 d: 1 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##set-slot-imm f 0 1 1 0 }
T{ ##slot-imm f 2 0 1 0 }
T{ peek## f 0 d: 0 }
T{ peek## f 1 d: 1 }
T{ slot-imm## f 1 0 1 0 }
T{ set-slot-imm## f 0 1 1 0 }
T{ slot-imm## f 2 0 1 0 }
}
} [
V{
T{ ##peek f 0 d: 0 }
T{ ##peek f 1 d: 1 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##set-slot-imm f 0 1 1 0 }
T{ ##slot-imm f 2 0 1 0 }
T{ peek## f 0 d: 0 }
T{ peek## f 1 d: 1 }
T{ slot-imm## f 1 0 1 0 }
T{ set-slot-imm## f 0 1 1 0 }
T{ slot-imm## f 2 0 1 0 }
} test-alias-analysis
] unit-test
! Not a redundant store
{
V{
T{ ##peek f 0 d: 0 }
T{ ##peek f 1 d: 1 }
T{ ##peek f 2 d: 2 }
T{ ##peek f 3 d: 3 }
T{ ##set-slot-imm f 2 1 1 0 }
T{ ##slot-imm f 4 0 1 0 }
T{ ##set-slot-imm f 3 1 1 0 }
T{ peek## f 0 d: 0 }
T{ peek## f 1 d: 1 }
T{ peek## f 2 d: 2 }
T{ peek## f 3 d: 3 }
T{ set-slot-imm## f 2 1 1 0 }
T{ slot-imm## f 4 0 1 0 }
T{ set-slot-imm## f 3 1 1 0 }
}
} [
V{
T{ ##peek f 0 d: 0 }
T{ ##peek f 1 d: 1 }
T{ ##peek f 2 d: 2 }
T{ ##peek f 3 d: 3 }
T{ ##set-slot-imm f 2 1 1 0 }
T{ ##slot-imm f 4 0 1 0 }
T{ ##set-slot-imm f 3 1 1 0 }
T{ peek## f 0 d: 0 }
T{ peek## f 1 d: 1 }
T{ peek## f 2 d: 2 }
T{ peek## f 3 d: 3 }
T{ set-slot-imm## f 2 1 1 0 }
T{ slot-imm## f 4 0 1 0 }
T{ set-slot-imm## f 3 1 1 0 }
} test-alias-analysis
] unit-test
! There's a redundant load, but not a redundant store
{
V{
T{ ##peek f 0 d: 0 }
T{ ##peek f 1 d: 1 }
T{ ##peek f 2 d: 2 }
T{ ##peek f 3 d: 3 }
T{ ##slot-imm f 4 0 1 0 }
T{ ##set-slot-imm f 2 0 1 0 }
T{ ##slot f 5 0 3 0 0 }
T{ ##set-slot-imm f 3 0 1 0 }
T{ ##copy f 6 3 any-rep }
T{ peek## f 0 d: 0 }
T{ peek## f 1 d: 1 }
T{ peek## f 2 d: 2 }
T{ peek## f 3 d: 3 }
T{ slot-imm## f 4 0 1 0 }
T{ set-slot-imm## f 2 0 1 0 }
T{ slot## f 5 0 3 0 0 }
T{ set-slot-imm## f 3 0 1 0 }
T{ copy## f 6 3 any-rep }
}
} [
V{
T{ ##peek f 0 d: 0 }
T{ ##peek f 1 d: 1 }
T{ ##peek f 2 d: 2 }
T{ ##peek f 3 d: 3 }
T{ ##slot-imm f 4 0 1 0 }
T{ ##set-slot-imm f 2 0 1 0 }
T{ ##slot f 5 0 3 0 0 }
T{ ##set-slot-imm f 3 0 1 0 }
T{ ##slot-imm f 6 0 1 0 }
T{ peek## f 0 d: 0 }
T{ peek## f 1 d: 1 }
T{ peek## f 2 d: 2 }
T{ peek## f 3 d: 3 }
T{ slot-imm## f 4 0 1 0 }
T{ set-slot-imm## f 2 0 1 0 }
T{ slot## f 5 0 3 0 0 }
T{ set-slot-imm## f 3 0 1 0 }
T{ slot-imm## f 6 0 1 0 }
} test-alias-analysis
] unit-test
@ -182,45 +182,45 @@ IN: compiler.cfg.alias-analysis.tests
! Redundant load elimination
{
V{
T{ ##peek f 1 d: 1 }
T{ ##peek f 2 d: 2 }
T{ ##peek f 3 d: 3 }
T{ ##allot f 4 16 array }
T{ ##set-slot-imm f 3 4 1 0 }
T{ ##set-slot-imm f 2 1 1 0 }
T{ ##copy f 5 3 any-rep }
T{ peek## f 1 d: 1 }
T{ peek## f 2 d: 2 }
T{ peek## f 3 d: 3 }
T{ allot## f 4 16 array }
T{ set-slot-imm## f 3 4 1 0 }
T{ set-slot-imm## f 2 1 1 0 }
T{ copy## f 5 3 any-rep }
}
} [
V{
T{ ##peek f 1 d: 1 }
T{ ##peek f 2 d: 2 }
T{ ##peek f 3 d: 3 }
T{ ##allot f 4 16 array }
T{ ##set-slot-imm f 3 4 1 0 }
T{ ##set-slot-imm f 2 1 1 0 }
T{ ##slot-imm f 5 4 1 0 }
T{ peek## f 1 d: 1 }
T{ peek## f 2 d: 2 }
T{ peek## f 3 d: 3 }
T{ allot## f 4 16 array }
T{ set-slot-imm## f 3 4 1 0 }
T{ set-slot-imm## f 2 1 1 0 }
T{ slot-imm## f 5 4 1 0 }
} test-alias-analysis
] unit-test
! Redundant store elimination
{
V{
T{ ##peek f 1 d: 1 }
T{ ##peek f 2 d: 2 }
T{ ##peek f 3 d: 3 }
T{ ##allot f 4 16 array }
T{ ##slot-imm f 5 1 1 0 }
T{ ##set-slot-imm f 3 4 1 0 }
T{ peek## f 1 d: 1 }
T{ peek## f 2 d: 2 }
T{ peek## f 3 d: 3 }
T{ allot## f 4 16 array }
T{ slot-imm## f 5 1 1 0 }
T{ set-slot-imm## f 3 4 1 0 }
}
} [
V{
T{ ##peek f 1 d: 1 }
T{ ##peek f 2 d: 2 }
T{ ##peek f 3 d: 3 }
T{ ##allot f 4 16 array }
T{ ##set-slot-imm f 1 4 1 0 }
T{ ##slot-imm f 5 1 1 0 }
T{ ##set-slot-imm f 3 4 1 0 }
T{ peek## f 1 d: 1 }
T{ peek## f 2 d: 2 }
T{ peek## f 3 d: 3 }
T{ allot## f 4 16 array }
T{ set-slot-imm## f 1 4 1 0 }
T{ slot-imm## f 5 1 1 0 }
T{ set-slot-imm## f 3 4 1 0 }
} test-alias-analysis
] unit-test
@ -228,63 +228,63 @@ IN: compiler.cfg.alias-analysis.tests
! can now alias the new ac
{
V{
T{ ##peek f 0 d: 0 }
T{ ##peek f 1 d: 1 }
T{ ##peek f 2 d: 2 }
T{ ##peek f 3 d: 3 }
T{ ##allot f 4 16 array }
T{ ##set-slot-imm f 0 4 1 0 }
T{ ##set-slot-imm f 4 2 1 0 }
T{ ##slot-imm f 5 3 1 0 }
T{ ##set-slot-imm f 1 5 1 0 }
T{ ##slot-imm f 6 4 1 0 }
T{ peek## f 0 d: 0 }
T{ peek## f 1 d: 1 }
T{ peek## f 2 d: 2 }
T{ peek## f 3 d: 3 }
T{ allot## f 4 16 array }
T{ set-slot-imm## f 0 4 1 0 }
T{ set-slot-imm## f 4 2 1 0 }
T{ slot-imm## f 5 3 1 0 }
T{ set-slot-imm## f 1 5 1 0 }
T{ slot-imm## f 6 4 1 0 }
}
} [
V{
T{ ##peek f 0 d: 0 }
T{ ##peek f 1 d: 1 }
T{ ##peek f 2 d: 2 }
T{ ##peek f 3 d: 3 }
T{ ##allot f 4 16 array }
T{ ##set-slot-imm f 0 4 1 0 }
T{ ##set-slot-imm f 4 2 1 0 }
T{ ##slot-imm f 5 3 1 0 }
T{ ##set-slot-imm f 1 5 1 0 }
T{ ##slot-imm f 6 4 1 0 }
T{ peek## f 0 d: 0 }
T{ peek## f 1 d: 1 }
T{ peek## f 2 d: 2 }
T{ peek## f 3 d: 3 }
T{ allot## f 4 16 array }
T{ set-slot-imm## f 0 4 1 0 }
T{ set-slot-imm## f 4 2 1 0 }
T{ slot-imm## f 5 3 1 0 }
T{ set-slot-imm## f 1 5 1 0 }
T{ slot-imm## f 6 4 1 0 }
} test-alias-analysis
] unit-test
! Compares between objects which cannot alias are eliminated
{
V{
T{ ##peek f 0 d: 0 }
T{ ##allot f 1 16 array }
T{ ##load-reference f 2 f }
T{ peek## f 0 d: 0 }
T{ allot## f 1 16 array }
T{ load-reference## f 2 f }
}
} [
V{
T{ ##peek f 0 d: 0 }
T{ ##allot f 1 16 array }
T{ ##compare f 2 0 1 cc= }
T{ peek## f 0 d: 0 }
T{ allot## f 1 16 array }
T{ compare## f 2 0 1 cc= }
} test-alias-analysis
] unit-test
! Make sure that input to ##box-displaced-alien becomes heap-ac
! Make sure that input to box-displaced-alien## becomes heap-ac
{
V{
T{ ##allot f 1 16 byte-array }
T{ ##load-reference f 2 10 }
T{ ##box-displaced-alien f 3 2 1 4 byte-array }
T{ ##slot-imm f 5 3 1 $[ alien type-number ] }
T{ ##compare f 6 5 1 cc= }
T{ allot## f 1 16 byte-array }
T{ load-reference## f 2 10 }
T{ box-displaced-alien## f 3 2 1 4 byte-array }
T{ slot-imm## f 5 3 1 $[ alien type-number ] }
T{ compare## f 6 5 1 cc= }
}
} [
V{
T{ ##allot f 1 16 byte-array }
T{ ##load-reference f 2 10 }
T{ ##box-displaced-alien f 3 2 1 4 byte-array }
T{ ##slot-imm f 5 3 1 $[ alien type-number ] }
T{ ##compare f 6 5 1 cc= }
T{ allot## f 1 16 byte-array }
T{ load-reference## f 2 10 }
T{ box-displaced-alien## f 3 2 1 4 byte-array }
T{ slot-imm## f 5 3 1 $[ alien type-number ] }
T{ compare## f 6 5 1 cc= }
} test-alias-analysis
] unit-test
@ -292,71 +292,71 @@ IN: compiler.cfg.alias-analysis.tests
! instructions which can call back into Factor code
{
V{
T{ ##peek f 0 d: 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
T{ ##slot-imm f 2 0 1 0 }
T{ peek## f 0 d: 0 }
T{ slot-imm## f 1 0 1 0 }
T{ alien-invoke## f { } { } { } { } 0 0 "free" }
T{ slot-imm## f 2 0 1 0 }
}
} [
V{
T{ ##peek f 0 d: 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
T{ ##slot-imm f 2 0 1 0 }
T{ peek## f 0 d: 0 }
T{ slot-imm## f 1 0 1 0 }
T{ alien-invoke## f { } { } { } { } 0 0 "free" }
T{ slot-imm## f 2 0 1 0 }
} test-alias-analysis
] unit-test
{
V{
T{ ##peek f 0 d: 0 }
T{ ##peek f 1 d: 1 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
T{ ##slot-imm f 2 0 1 0 }
T{ peek## f 0 d: 0 }
T{ peek## f 1 d: 1 }
T{ set-slot-imm## f 1 0 1 0 }
T{ alien-invoke## f { } { } { } { } 0 0 "free" }
T{ slot-imm## f 2 0 1 0 }
}
} [
V{
T{ ##peek f 0 d: 0 }
T{ ##peek f 1 d: 1 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
T{ ##slot-imm f 2 0 1 0 }
T{ peek## f 0 d: 0 }
T{ peek## f 1 d: 1 }
T{ set-slot-imm## f 1 0 1 0 }
T{ alien-invoke## f { } { } { } { } 0 0 "free" }
T{ slot-imm## f 2 0 1 0 }
} test-alias-analysis
] unit-test
{
V{
T{ ##peek f 0 d: 0 }
T{ ##peek f 1 d: 1 }
T{ ##peek f 2 d: 2 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
T{ ##set-slot-imm f 2 0 1 0 }
T{ peek## f 0 d: 0 }
T{ peek## f 1 d: 1 }
T{ peek## f 2 d: 2 }
T{ set-slot-imm## f 1 0 1 0 }
T{ alien-invoke## f { } { } { } { } 0 0 "free" }
T{ set-slot-imm## f 2 0 1 0 }
}
} [
V{
T{ ##peek f 0 d: 0 }
T{ ##peek f 1 d: 1 }
T{ ##peek f 2 d: 2 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
T{ ##set-slot-imm f 2 0 1 0 }
T{ peek## f 0 d: 0 }
T{ peek## f 1 d: 1 }
T{ peek## f 2 d: 2 }
T{ set-slot-imm## f 1 0 1 0 }
T{ alien-invoke## f { } { } { } { } 0 0 "free" }
T{ set-slot-imm## f 2 0 1 0 }
} test-alias-analysis
] unit-test
{
V{
T{ ##peek f 0 d: 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
T{ ##set-slot-imm f 1 0 1 0 }
T{ peek## f 0 d: 0 }
T{ slot-imm## f 1 0 1 0 }
T{ alien-invoke## f { } { } { } { } 0 0 "free" }
T{ set-slot-imm## f 1 0 1 0 }
}
} [
V{
T{ ##peek f 0 d: 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
T{ ##set-slot-imm f 1 0 1 0 }
T{ peek## f 0 d: 0 }
T{ slot-imm## f 1 0 1 0 }
T{ alien-invoke## f { } { } { } { } 0 0 "free" }
T{ set-slot-imm## f 1 0 1 0 }
} test-alias-analysis
] unit-test
@ -364,70 +364,70 @@ IN: compiler.cfg.alias-analysis.tests
! instruction
{
V{
T{ ##allot f 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
T{ ##copy f 2 1 any-rep }
T{ allot## f 0 }
T{ slot-imm## f 1 0 1 0 }
T{ alien-invoke## f { } { } { } { } 0 0 "free" }
T{ copy## f 2 1 any-rep }
}
} [
V{
T{ ##allot f 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
T{ ##slot-imm f 2 0 1 0 }
T{ allot## f 0 }
T{ slot-imm## f 1 0 1 0 }
T{ alien-invoke## f { } { } { } { } 0 0 "free" }
T{ slot-imm## f 2 0 1 0 }
} test-alias-analysis
] unit-test
{
V{
T{ ##allot f 0 }
T{ ##peek f 1 d: 1 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
T{ ##copy f 2 1 any-rep }
T{ allot## f 0 }
T{ peek## f 1 d: 1 }
T{ set-slot-imm## f 1 0 1 0 }
T{ alien-invoke## f { } { } { } { } 0 0 "free" }
T{ copy## f 2 1 any-rep }
}
} [
V{
T{ ##allot f 0 }
T{ ##peek f 1 d: 1 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
T{ ##slot-imm f 2 0 1 0 }
T{ allot## f 0 }
T{ peek## f 1 d: 1 }
T{ set-slot-imm## f 1 0 1 0 }
T{ alien-invoke## f { } { } { } { } 0 0 "free" }
T{ slot-imm## f 2 0 1 0 }
} test-alias-analysis
] unit-test
{
V{
T{ ##allot f 0 }
T{ ##peek f 1 d: 1 }
T{ ##peek f 2 d: 2 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
T{ ##set-slot-imm f 2 0 1 0 }
T{ allot## f 0 }
T{ peek## f 1 d: 1 }
T{ peek## f 2 d: 2 }
T{ set-slot-imm## f 1 0 1 0 }
T{ alien-invoke## f { } { } { } { } 0 0 "free" }
T{ set-slot-imm## f 2 0 1 0 }
}
} [
V{
T{ ##allot f 0 }
T{ ##peek f 1 d: 1 }
T{ ##peek f 2 d: 2 }
T{ ##set-slot-imm f 1 0 1 0 }
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
T{ ##set-slot-imm f 2 0 1 0 }
T{ allot## f 0 }
T{ peek## f 1 d: 1 }
T{ peek## f 2 d: 2 }
T{ set-slot-imm## f 1 0 1 0 }
T{ alien-invoke## f { } { } { } { } 0 0 "free" }
T{ set-slot-imm## f 2 0 1 0 }
} test-alias-analysis
] unit-test
{
V{
T{ ##allot f 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
T{ allot## f 0 }
T{ slot-imm## f 1 0 1 0 }
T{ alien-invoke## f { } { } { } { } 0 0 "free" }
}
} [
V{
T{ ##allot f 0 }
T{ ##slot-imm f 1 0 1 0 }
T{ ##alien-invoke f { } { } { } { } 0 0 "free" }
T{ ##set-slot-imm f 1 0 1 0 }
T{ allot## f 0 }
T{ slot-imm## f 1 0 1 0 }
T{ alien-invoke## f { } { } { } { } 0 0 "free" }
T{ set-slot-imm## f 1 0 1 0 }
} test-alias-analysis
] unit-test
@ -435,14 +435,14 @@ IN: compiler.cfg.alias-analysis.tests
! handled properly
{
V{
T{ ##allot f 0 }
T{ ##alien-indirect f f { } { } { { 2 double-rep 0 } } { } 0 0 "free" }
T{ ##set-slot-imm f 2 0 1 0 }
T{ allot## f 0 }
T{ alien-indirect## f f { } { } { { 2 double-rep 0 } } { } 0 0 "free" }
T{ set-slot-imm## f 2 0 1 0 }
}
} [
V{
T{ ##allot f 0 }
T{ ##alien-indirect f f { } { } { { 2 double-rep 0 } } { } 0 0 "free" }
T{ ##set-slot-imm f 2 0 1 0 }
T{ allot## f 0 }
T{ alien-indirect## f f { } { } { { 2 double-rep 0 } } { } 0 0 "free" }
T{ set-slot-imm## f 2 0 1 0 }
} test-alias-analysis
] unit-test

50
basis/compiler/cfg/alias-analysis/alias-analysis.factor
View File

@ -12,7 +12,7 @@ SYMBOL: copies
: resolve ( vreg -- vreg ) copies get ?at drop ;
: record-copy ( ##copy -- )
: record-copy ( copy## -- )
[ src>> resolve ] [ dst>> ] bi copies get set-at ; inline
! Map vregs -> alias classes
@ -30,8 +30,8 @@ SYMBOL: heap-ac
acs>vregs get [ drop V{ } clone ] cache ;
: vreg>ac ( vreg -- ac )
! Only vregs produced by ##allot, ##peek and ##slot can
! ever be used as valid inputs to ##slot and ##set-slot,
! Only vregs produced by allot##, peek## and slot## can
! ever be used as valid inputs to slot## and set-slot##,
! so we assert this fact by not giving alias classes to
! other vregs.
vregs>acs get [ heap-ac get [ ac>vregs push ] keep ] cache ;
@ -58,7 +58,7 @@ SYMBOL: live-slots
! Maps vreg -> slot# -> insn# of last store or f
SYMBOL: recent-stores
! A set of insn#s of dead stores
! A set of insns# of dead stores
SYMBOL: dead-stores
: dead-store ( insn# -- ) dead-stores get adjoin ;
@ -136,21 +136,21 @@ SYMBOL: ac-counter
GENERIC: insn-slot# ( insn -- slot#/f )
GENERIC: insn-object ( insn -- vreg )
M: ##slot insn-slot# drop f ;
M: ##slot-imm insn-slot# slot>> ;
M: ##set-slot insn-slot# drop f ;
M: ##set-slot-imm insn-slot# slot>> ;
M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
M: ##vm-field insn-slot# offset>> ;
M: ##set-vm-field insn-slot# offset>> ;
M: slot## insn-slot# drop f ;
M: slot-imm## insn-slot# slot>> ;
M: set-slot## insn-slot# drop f ;
M: set-slot-imm## insn-slot# slot>> ;
M: alien-global## insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
M: vm-field## insn-slot# offset>> ;
M: set-vm-field## insn-slot# offset>> ;
M: ##slot insn-object obj>> resolve ;
M: ##slot-imm insn-object obj>> resolve ;
M: ##set-slot insn-object obj>> resolve ;
M: ##set-slot-imm insn-object obj>> resolve ;
M: ##alien-global insn-object drop ##alien-global ;
M: ##vm-field insn-object drop ##vm-field ;
M: ##set-vm-field insn-object drop ##vm-field ;
M: slot## insn-object obj>> resolve ;
M: slot-imm## insn-object obj>> resolve ;
M: set-slot## insn-object obj>> resolve ;
M: set-slot-imm## insn-object obj>> resolve ;
M: alien-global## insn-object drop alien-global## ;
M: vm-field## insn-object drop vm-field## ;
M: set-vm-field## insn-object drop vm-field## ;
GENERIC: analyze-aliases ( insn -- insn' )
@ -175,7 +175,7 @@ M: allocation-insn analyze-aliases
! object.
dup dst>> set-new-ac ;
M: ##box-displaced-alien analyze-aliases
M: box-displaced-alien## analyze-aliases
[ call-next-method ]
[ base>> heap-ac get merge-acs ] bi ;
@ -206,7 +206,7 @@ M:: write-insn analyze-aliases ( insn -- insn )
insn ;
M: ##copy analyze-aliases
M: copy## analyze-aliases
! The output vreg gets the same alias class as the input
! vreg, since they both contain the same value.
dup record-copy ;
@ -217,10 +217,10 @@ M: ##copy analyze-aliases
[ [ src1>> ] [ src2>> ] bi [ resolve vreg>ac ] same? not ]
} 1&& ; inline
M: ##compare analyze-aliases
M: compare## analyze-aliases
call-next-method
dup useless-compare? [
dst>> f ##load-reference new-insn
dst>> f load-reference## new-insn
analyze-aliases
] when ;
@ -242,7 +242,7 @@ M: alien-call-insn analyze-aliases
GENERIC: eliminate-dead-stores ( insn -- ? )
M: ##set-slot-imm eliminate-dead-stores
M: set-slot-imm## eliminate-dead-stores
insn#>> dead-stores get in? not ;
M: insn eliminate-dead-stores drop t ;
@ -256,8 +256,8 @@ M: insn eliminate-dead-stores drop t ;
dead-stores get clear-set
next-ac heap-ac namespaces:set
##vm-field set-new-ac
##alien-global set-new-ac ;
vm-field## set-new-ac
alien-global## set-new-ac ;
: alias-analysis-step ( insns -- insns' )
reset-alias-analysis

2
basis/compiler/cfg/block-joining/block-joining-docs.factor
View File

@ -16,6 +16,6 @@ HELP: join-blocks
{ $description "A compiler pass when optimizing the cfg." } ;
ARTICLE: "compiler.cfg.block-joining" "Block Joining"
"Joining blocks that are not calls and are connected by a single CFG edge. This pass does not update " { $link ##phi } " nodes and should therefore only run before stack analysis or after ##phi node elimination." ;
"Joining blocks that are not calls and are connected by a single CFG edge. This pass does not update " { $link phi## } " nodes and should therefore only run before stack analysis or after phi## node elimination." ;
ABOUT: "compiler.cfg.block-joining"

38
basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor
View File

@ -17,31 +17,31 @@ IN: compiler.cfg.branch-splitting.tests
: test-branch-splitting ( -- )
0 get block>cfg check-branch-splitting ;
V{ T{ ##branch } } 0 test-bb
V{ T{ branch## } } 0 test-bb
V{ T{ ##branch } } 1 test-bb
V{ T{ branch## } } 1 test-bb
V{ T{ ##branch } } 2 test-bb
V{ T{ branch## } } 2 test-bb
V{ T{ ##branch } } 3 test-bb
V{ T{ branch## } } 3 test-bb
V{ T{ ##branch } } 4 test-bb
V{ T{ branch## } } 4 test-bb
test-diamond
{ } [ test-branch-splitting ] unit-test
V{ T{ ##branch } } 0 test-bb
V{ T{ branch## } } 0 test-bb
V{ T{ ##branch } } 1 test-bb
V{ T{ branch## } } 1 test-bb
V{ T{ ##branch } } 2 test-bb
V{ T{ branch## } } 2 test-bb
V{ T{ ##branch } } 3 test-bb
V{ T{ branch## } } 3 test-bb
V{ T{ ##branch } } 4 test-bb
V{ T{ branch## } } 4 test-bb
V{ T{ ##branch } } 5 test-bb
V{ T{ branch## } } 5 test-bb
0 { 1 2 } edges
@ -51,15 +51,15 @@ V{ T{ ##branch } } 5 test-bb
{ } [ test-branch-splitting ] unit-test
V{ T{ ##branch } } 0 test-bb
V{ T{ branch## } } 0 test-bb
V{ T{ ##branch } } 1 test-bb
V{ T{ branch## } } 1 test-bb
V{ T{ ##branch } } 2 test-bb
V{ T{ branch## } } 2 test-bb
V{ T{ ##branch } } 3 test-bb
V{ T{ branch## } } 3 test-bb
V{ T{ ##branch } } 4 test-bb
V{ T{ branch## } } 4 test-bb
0 { 1 2 } edges
@ -69,11 +69,11 @@ V{ T{ ##branch } } 4 test-bb
{ } [ test-branch-splitting ] unit-test
V{ T{ ##branch } } 0 test-bb
V{ T{ branch## } } 0 test-bb
V{ T{ ##branch } } 1 test-bb
V{ T{ branch## } } 1 test-bb
V{ T{ ##branch } } 2 test-bb
V{ T{ branch## } } 2 test-bb
0 { 1 2 } edges

2
basis/compiler/cfg/branch-splitting/branch-splitting.factor
View File

@ -48,7 +48,7 @@ IN: compiler.cfg.branch-splitting
[ update-successor-predecessors ]
2bi ;
UNION: irrelevant ##peek ##replace ##inc ;
UNION: irrelevant peek## replace## inc## ;
: split-instructions? ( insns -- ? ) [ irrelevant? not ] count 5 <= ;

6
basis/compiler/cfg/build-stack-frame/build-stack-frame-tests.factor
View File

@ -30,13 +30,13 @@ IN: compiler.cfg.build-stack-frame.tests
] unit-test
{ t } [
{ T{ ##call-gc } } insns>cfg dup build-stack-frame
{ T{ call-gc## } } insns>cfg dup build-stack-frame
stack-frame>> stack-frame?
] unit-test
{ 0 } [
{
T{ ##call-gc }
T{ ##local-allot { dst 1 } { size 32 } { align 8 } }
T{ call-gc## }
T{ local-allot## { dst 1 } { size 32 } { align 8 } }
} insns>cfg dup build-stack-frame cfg>insns last offset>>
] unit-test

24
basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
View File

@ -9,7 +9,7 @@ SYMBOLS: param-area-size allot-area-size allot-area-align ;
GENERIC: compute-stack-frame* ( insn -- ? )
M:: ##local-allot compute-stack-frame* ( insn -- ? )
M:: local-allot## compute-stack-frame* ( insn -- ? )
insn size>> :> s
insn align>> :> a
allot-area-align [ a max ] change
@ -21,21 +21,21 @@ M: alien-call-insn compute-stack-frame*
: vm-frame-required ( -- ? )
vm-stack-space param-area-size [ max ] change t ;
M: ##call-gc compute-stack-frame* drop vm-frame-required ;
M: ##box compute-stack-frame* drop vm-frame-required ;
M: ##unbox compute-stack-frame* drop vm-frame-required ;
M: ##box-long-long compute-stack-frame* drop vm-frame-required ;
M: ##callback-inputs compute-stack-frame* drop vm-frame-required ;
M: ##callback-outputs compute-stack-frame* drop vm-frame-required ;
M: call-gc## compute-stack-frame* drop vm-frame-required ;
M: box## compute-stack-frame* drop vm-frame-required ;
M: unbox## compute-stack-frame* drop vm-frame-required ;
M: box-long-long## compute-stack-frame* drop vm-frame-required ;
M: callback-inputs## compute-stack-frame* drop vm-frame-required ;
M: callback-outputs## compute-stack-frame* drop vm-frame-required ;
M: ##call compute-stack-frame* drop t ;
M: ##spill compute-stack-frame* drop t ;
M: ##reload compute-stack-frame* drop t ;
M: call## compute-stack-frame* drop t ;
M: spill## compute-stack-frame* drop t ;
M: reload## compute-stack-frame* drop t ;
M: ##float>integer compute-stack-frame*
M: float>integer## compute-stack-frame*
drop integer-float-needs-stack-frame? ;
M: ##integer>float compute-stack-frame*
M: integer>float## compute-stack-frame*
drop integer-float-needs-stack-frame? ;
M: insn compute-stack-frame* drop f ;

8
basis/compiler/cfg/builder/alien/alien-docs.factor
View File

@ -8,12 +8,12 @@ IN: compiler.cfg.builder.alien
CONSTANT: ex-caller-return [[
USING: compiler.cfg.builder.alien make prettyprint ;
[
T{ ##alien-invoke { reg-outputs { { 1 int-rep RAX } } } } ,
T{ alien-invoke## { reg-outputs { { 1 int-rep RAX } } } } ,
T{ alien-invoke-params { return pointer: void } } caller-return
] { } make .
{
T{ ##alien-invoke { reg-outputs { { 1 int-rep RAX } } } }
T{ ##box-alien { dst 116 } { src 1 } { temp 115 } }
T{ alien-invoke## { reg-outputs { { 1 int-rep RAX } } } }
T{ box-alien## { dst 116 } { src 1 } { temp 115 } }
}
]]
>>
@ -45,7 +45,7 @@ HELP: emit-callback-body
HELP: emit-callback-return
{ $values { "block" basic-block } { "params" alien-node-params } }
{ $description "Emits a " { $link ##callback-outputs } " instruction for the " { $link #alien-callback } " if needed." } ;
{ $description "Emits a " { $link callback-outputs## } " instruction for the " { $link alien-callback# } " if needed." } ;
HELP: unbox-parameters
{ $values { "parameters" sequence } { "vregs" sequence } { "reps" sequence } }

18
basis/compiler/cfg/builder/alien/alien-tests.factor
View File

@ -29,12 +29,12 @@ IN: compiler.cfg.builder.alien.tests
{
V{
T{ ##load-reference { dst 1 } { obj t } }
T{ ##load-integer { dst 2 } { val 3 } }
T{ ##copy { dst 4 } { src 1 } { rep any-rep } }
T{ ##copy { dst 3 } { src 2 } { rep any-rep } }
T{ ##inc { loc d: 2 } }
T{ ##branch }
T{ load-reference## { dst 1 } { obj t } }
T{ load-integer## { dst 2 } { val 3 } }
T{ copy## { dst 4 } { src 1 } { rep any-rep } }
T{ copy## { dst 3 } { src 2 } { rep any-rep } }
T{ inc## { loc d: 2 } }
T{ branch## }
}
} [
<basic-block> dup set-basic-block
@ -115,8 +115,8 @@ cpu x86.32?
{ 2 4 }
{ { int-rep f f } { int-rep f f } }
V{
T{ ##unbox-any-c-ptr { dst 2 } { src 1 } }
T{ ##unbox
T{ unbox-any-c-ptr## { dst 2 } { src 1 } }
T{ unbox##
{ dst 4 }
{ src 3 }
{ unboxer "to_fixnum" }
@ -127,7 +127,7 @@ cpu x86.32?
{
{ 2 3 }
{ { int-rep f f } { int-rep f f } }
V{ T{ ##unbox-any-c-ptr { dst 2 } { src 1 } } }
V{ T{ unbox-any-c-ptr## { dst 2 } { src 1 } } }
} ? [
[ { c-string int } unbox-parameters ] V{ } make
] cfg-unit-test

20
basis/compiler/cfg/builder/alien/alien.factor
View File

@ -93,30 +93,30 @@ IN: compiler.cfg.builder.alien
[ stack-params get [ caller-stack-cleanup ] keep ]
} cleave ;
M: #alien-invoke emit-node ( block node -- block' )
M: alien-invoke# emit-node ( block node -- block' )
params>>
[
[ params>alien-insn-params ]
[ caller-linkage ] bi
<gc-map> ##alien-invoke,
<gc-map> alien-invoke##,
]
[ caller-return ] bi ;
M: #alien-indirect emit-node ( block node -- block' )
M: alien-indirect# emit-node ( block node -- block' )
params>>
[
[ ds-pop ^^unbox-any-c-ptr ] dip
params>alien-insn-params
<gc-map> ##alien-indirect,
<gc-map> alien-indirect##,
]
[ caller-return ] bi ;
M: #alien-assembly emit-node ( block node -- block' )
M: alien-assembly# emit-node ( block node -- block' )
params>>
[
[ params>alien-insn-params ]
[ quot>> ] bi
##alien-assembly,
alien-assembly##,
]
[ caller-return ] bi ;
@ -149,10 +149,10 @@ M: #alien-assembly emit-node ( block node -- block' )
] if-void ;
: emit-callback-body ( block nodes -- block' )
dup last #return? t assert= but-last emit-nodes ;
dup last return#? t assert= but-last emit-nodes ;
: emit-callback-inputs ( params -- )
[ callee-parameters ##callback-inputs, ] keep box-parameters ;
[ callee-parameters callback-inputs##, ] keep box-parameters ;
: callback-stack-cleanup ( params -- )
[ xt>> ]
@ -160,12 +160,12 @@ M: #alien-assembly emit-node ( block node -- block' )
"stack-cleanup" set-word-prop ;
: emit-callback-return ( block params -- )
swap [ callee-return ##callback-outputs, ] [ drop ] if ;
swap [ callee-return callback-outputs##, ] [ drop ] if ;
: emit-callback-outputs ( block params -- )
[ emit-callback-return ] keep callback-stack-cleanup ;
M: #alien-callback emit-node ( block node -- block' )
M: alien-callback# emit-node ( block node -- block' )
dup params>> xt>> dup
[
t cfg get frame-pointer?<<

10
basis/compiler/cfg/builder/alien/boxing/boxing-docs.factor
View File

@ -9,15 +9,15 @@ HELP: box
{ "c-type" c-type }
{ "dst" "box" }
}
{ $description "Emits a " { $link ##box-alien } " instruction which boxes an alien value contained in the given register." }
{ $description "Emits a " { $link box-alien## } " instruction which boxes an alien value contained in the given register." }
{ $examples
{ $unchecked-example
"USING: compiler.cfg.builder.alien.boxing make prettyprint ;"
"{ 71 } { int-rep } void* base-type [ box ] { } make nip ."
"{ T{ ##box-alien { dst 105 } { src 71 } { temp 104 } } }"
"{ T{ box-alien## { dst 105 } { src 71 } { temp 104 } } }"
}
}
{ $see-also ##box-alien } ;
{ $see-also box-alien## } ;
HELP: box-return
{ $values
@ -31,10 +31,10 @@ HELP: box-return
{ $unchecked-example
"USING: compiler.cfg.builder.alien.boxing kernel make prettyprint ;"
"[ { 10 } { tagged-rep } int base-type box-return drop ] { } make ."
"{ T{ ##convert-integer { dst 118 } { src 10 } { c-type int } } }"
"{ T{ convert-integer## { dst 118 } { src 10 } { c-type int } } }"
}
}
{ $see-also ##box-alien } ;
{ $see-also box-alien## } ;
HELP: flatten-c-type
{ $values { "c-type" abstract-c-type } { "pairs" sequence } }

22
basis/compiler/cfg/builder/alien/boxing/boxing-tests.factor
View File

@ -39,7 +39,7 @@ cpu x86.32?
{ 1 }
{ { int-rep f f } }
{
T{ ##unbox
T{ unbox##
{ dst 1 }
{ src 20 }
{ unboxer "to_fixnum" }
@ -64,26 +64,26 @@ cpu x86.32?
{ int-rep t f }
}
{
T{ ##unbox-any-c-ptr { dst 1 } { src 20 } }
T{ ##load-memory-imm
T{ unbox-any-c-ptr## { dst 1 } { src 20 } }
T{ load-memory-imm##
{ dst 2 }
{ base 1 }
{ offset 0 }
{ rep int-rep }
}
T{ ##load-memory-imm
T{ load-memory-imm##
{ dst 3 }
{ base 1 }
{ offset 4 }
{ rep int-rep }
}
T{ ##load-memory-imm
T{ load-memory-imm##
{ dst 4 }
{ base 1 }
{ offset 8 }
{ rep int-rep }
}
T{ ##load-memory-imm
T{ load-memory-imm##
{ dst 5 }
{ base 1 }
{ offset 12 }
@ -94,14 +94,14 @@ cpu x86.32?
{ 2 3 }
{ { int-rep f f } { int-rep f f } }
{
T{ ##unbox-any-c-ptr { dst 1 } { src 20 } }
T{ ##load-memory-imm
T{ unbox-any-c-ptr## { dst 1 } { src 20 } }
T{ load-memory-imm##
{ dst 2 }
{ base 1 }
{ offset 0 }
{ rep int-rep }
}
T{ ##load-memory-imm
T{ load-memory-imm##
{ dst 3 }
{ base 1 }
{ offset 8 }
@ -116,7 +116,7 @@ cpu x86.32?
{
{ 1 }
{ { int-rep f f } }
{ T{ ##unbox-any-c-ptr { dst 1 } { src 77 } } }
{ T{ unbox-any-c-ptr## { dst 1 } { src 77 } } }
} [
[ 77 c-string base-type unbox-parameter ] { } make
] cfg-unit-test
@ -127,7 +127,7 @@ cpu x86.32?
{ 1 }
{ { int-rep f f } }
{
T{ ##unbox
T{ unbox##
{ dst 1 }
{ src 77 }
{ unboxer "to_fixnum" }

4
basis/compiler/cfg/builder/alien/boxing/boxing.factor
View File

@ -50,7 +50,7 @@ M: object flatten-struct-type-return
:: implode-struct ( src vregs reps -- )
vregs reps dup component-offsets
|[ vreg rep offset | vreg src offset rep f ##store-memory-imm, ] 3each ;
|[ vreg rep offset | vreg src offset rep f store-memory-imm##, ] 3each ;
GENERIC: unbox ( src c-type -- vregs reps )
@ -73,7 +73,7 @@ M: c-type unbox
[ drop f f 3array 1array ] 2bi ;
M: long-long-type unbox
[ next-vreg next-vreg 2dup ] 2dip unboxer>> ##unbox-long-long, 2array
[ next-vreg next-vreg 2dup ] 2dip unboxer>> unbox-long-long##, 2array
int-rep long-long-on-stack? long-long-odd-register? 3array
int-rep long-long-on-stack? f 3array 2array ;

10
basis/compiler/cfg/builder/blocks/blocks-docs.factor
View File

@ -5,10 +5,10 @@ IN: compiler.cfg.builder.blocks
<<
CONSTANT: ex-emit-trivial-block [[
USING: compiler.cfg.builder.blocks make prettyprint ;
begin-stack-analysis <basic-block> dup set-basic-block [ gensym ##call, drop ] emit-trivial-block predecessors>> first .
begin-stack-analysis <basic-block> dup set-basic-block [ gensym call##, drop ] emit-trivial-block predecessors>> first .
T{ basic-block
{ instructions
V{ T{ ##call { word ( gensym ) } } T{ ##branch } }
V{ T{ call## { word ( gensym ) } } T{ branch## } }
}
{ successors
V{
@ -18,7 +18,7 @@ T{ basic-block
{ predecessors
V{
T{ basic-block
{ instructions V{ T{ ##branch } } }
{ instructions V{ T{ branch## } } }
{ successors V{ ~circularity~ } }
}
}
@ -39,8 +39,8 @@ HELP: begin-branch
{ $description "Used to begin emitting a branch." } ;
HELP: call-height
{ $values { "#call" #call } { "n" number } }
{ $description "Calculates how many items a " { $link #call } " will add or remove from the data stack." }
{ $values { "call#" call# } { "n" number } }
{ $description "Calculates how many items a " { $link call# } " will add or remove from the data stack." }
{ $examples
{ $example
"USING: compiler.cfg.builder.blocks compiler.tree.builder prettyprint sequences ;"

8
basis/compiler/cfg/builder/blocks/blocks-tests.factor
View File

@ -21,7 +21,7 @@ IN: compiler.cfg.builder.blocks.tests
! emit-call-block
{
V{ T{ ##call { word 2drop } } }
V{ T{ call## { word 2drop } } }
T{ height-state f 0 0 -2 0 }
} [
\ 2drop -2 <basic-block> [ emit-call-block ] V{ } make
@ -30,16 +30,16 @@ IN: compiler.cfg.builder.blocks.tests
! emit-trivial-block
{
V{ T{ ##no-tco } T{ ##branch } }
V{ T{ no-tco## } T{ branch## } }
} [
<basic-block> dup set-basic-block
[ drop ##no-tco, ] emit-trivial-block
[ drop no-tco##, ] emit-trivial-block
predecessors>> first instructions>>
] cfg-unit-test
! end-basic-block
{ } [
<basic-block> dup set-basic-block ##branch, end-basic-block
<basic-block> dup set-basic-block branch##, end-basic-block
] unit-test
{

12
basis/compiler/cfg/builder/blocks/blocks.factor
View File

@ -20,21 +20,21 @@ SLOT: out-d
dup end-basic-block (begin-basic-block) ;
: emit-trivial-block ( block quot: ( ..a block' -- ..b ) -- block' )
##branch, swap begin-basic-block
branch##, swap begin-basic-block
[ swap call ] keep
##branch, begin-basic-block ; inline
branch##, begin-basic-block ; inline
: call-height ( #call -- n )
: call-height ( call# -- n )
[ out-d>> length ] [ in-d>> length ] bi - ;
: emit-call-block ( word height block -- )
t swap kill-block?<<
<ds-loc> inc-stack ##call, ;
<ds-loc> inc-stack call##, ;
: emit-trivial-call ( block word height -- block' )
rot [ emit-call-block ] emit-trivial-block ;
: emit-primitive ( block #call -- block' )
: emit-primitive ( block call# -- block' )
[ word>> ] [ call-height ] bi emit-trivial-call ;
: begin-branch ( block -- block' )
@ -42,7 +42,7 @@ SLOT: out-d
: end-branch ( block/f -- pair/f )
dup [
##branch,
branch##,
end-local-analysis
height-state get clone 2array
] when* ;

34
basis/compiler/cfg/builder/builder-docs.factor
View File

@ -20,8 +20,8 @@ T{ basic-block
{ id 1903166 }
{ instructions
V{
T{ ##call { word dummy } }
T{ ##branch }
T{ call## { word dummy } }
T{ branch## }
}
}
{ successors
@ -36,7 +36,7 @@ T{ basic-block
CONSTANT: ex-make-input-map [[
USING: compiler.cfg.builder prettyprint ;
T{ #shuffle { in-d { 37 81 92 } } } make-input-map .
T{ shuffle# { in-d { 37 81 92 } } } make-input-map .
{ { 37 d: 2 } { 81 d: 1 } { 92 d: 0 } }
]]
>>
@ -50,7 +50,7 @@ HELP: procedures
{ $see-also build-cfg } ;
HELP: make-input-map
{ $values { "#shuffle" #shuffle } { "assoc" assoc } }
{ $values { "shuffle#" shuffle# } { "assoc" assoc } }
{ $description "Creates an " { $link assoc } " that maps input values to the shuffle operation to stack locations." }
{ $examples { $unchecked-example $[ ex-make-input-map ] } } ;
@ -82,9 +82,9 @@ HELP: emit-node
$nl
"The following classes emit-node methods does not change the current block:"
{ $list
{ $link #alien-assembly }
{ $link #alien-callback }
{ $link #alien-indirect }
{ $link alien-assembly# }
{ $link alien-callback# }
{ $link alien-indirect# }
}
} ;
@ -101,21 +101,21 @@ HELP: end-word
{ "block" "current " { $link basic-block } }
{ "block'" basic-block }
}
{ $description "Ends the word by adding a basic block containing a " { $link ##return } " instructions to the " { $link cfg } "." } ;
{ $description "Ends the word by adding a basic block containing a " { $link return## } " instructions to the " { $link cfg } "." } ;
HELP: height-changes
{ $values { "#shuffle" #shuffle } { "height-changes" pair } }
{ $description "Returns a two-tuple which represents how much the " { $link #shuffle } " node increases or decreases the data and retainstacks." }
{ $values { "shuffle#" shuffle# } { "height-changes" pair } }
{ $description "Returns a two-tuple which represents how much the " { $link shuffle# } " node increases or decreases the data and retainstacks." }
{ $examples
{ $example
"USING: compiler.cfg.builder compiler.tree prettyprint ;"
"T{ #shuffle { in-d { 37 81 92 } } { out-d { 20 } } } height-changes ."
"T{ shuffle# { in-d { 37 81 92 } } { out-d { 20 } } } height-changes ."
"{ -2 0 }"
}
} ;
HELP: out-vregs/stack
{ $values { "#shuffle" #shuffle } { "pair" sequence } }
{ $values { "shuffle#" shuffle# } { "pair" sequence } }
{ $description "Returns a sequence of what vregs are on which stack locations after the shuffle instruction." } ;
HELP: trivial-branch?
@ -128,7 +128,7 @@ HELP: trivial-branch?
{ $examples
{ $example
"USING: compiler.cfg.builder compiler.tree prettyprint ;"
"{ T{ #push { literal 25 } } } trivial-branch? . ."
"{ T{ push# { literal 25 } } } trivial-branch? . ."
"t\n25"
}
} ;
@ -156,26 +156,26 @@ $nl
{ $subsections
with-cfg-builder
}
"Emitters for " { $link #call } ":"
"Emitters for " { $link call# } ":"
{ $subsections
emit-call
emit-loop-call
}
"Emitters for " { $link #dispatch } " and " { $link #if } ":"
"Emitters for " { $link dispatch# } " and " { $link if# } ":"
{ $subsections
emit-actual-if
emit-branch
emit-if
emit-trivial-if
}
"Emitters for " { $link #recursive } ":"
"Emitters for " { $link recursive# } ":"
{
$subsections
emit-loop
emit-recursive
end-branch
}
"Helpers for " { $link #shuffle } ":"
"Helpers for " { $link shuffle# } ":"
{
$subsections
height-changes

94
basis/compiler/cfg/builder/builder-tests.factor
View File

@ -169,73 +169,73 @@ IN: compiler.cfg.builder.tests
{ pinned-c-ptr class fixnum } \ set-alien-cell '[ _ declare _ execute ] unit-test-builder
] each
{ t } [ [ swap ] [ ##replace? ] contains-insn? ] unit-test
{ t } [ [ swap ] [ replace##? ] contains-insn? ] unit-test
{ f } [ [ swap swap ] [ ##replace? ] contains-insn? ] unit-test
{ f } [ [ swap swap ] [ replace##? ] contains-insn? ] unit-test
{ t } [
[ { fixnum byte-array fixnum } declare set-alien-unsigned-1 ]
[ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
[ [ store-memory##? ] [ store-memory-imm##? ] bi or ] contains-insn?
] unit-test
{ t } [
[ { fixnum byte-array fixnum } declare [ dup * dup * ] 2dip set-alien-unsigned-1 ]
[ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
[ [ store-memory##? ] [ store-memory-imm##? ] bi or ] contains-insn?
] unit-test
{ f } [
[ { byte-array fixnum } declare set-alien-unsigned-1 ]
[ [ ##store-memory? ] [ ##store-memory-imm? ] bi or ] contains-insn?
[ [ store-memory##? ] [ store-memory-imm##? ] bi or ] contains-insn?
] unit-test
{ t t } [
[ { byte-array fixnum } declare alien-cell ]
[ [ [ ##load-memory? ] [ ##load-memory-imm? ] bi or ] contains-insn? ]
[ [ ##box-alien? ] contains-insn? ]
[ [ [ load-memory##? ] [ load-memory-imm##? ] bi or ] contains-insn? ]
[ [ box-alien##? ] contains-insn? ]
bi
] unit-test
{ f } [
[ { byte-array integer } declare alien-cell ]
[ [ ##load-memory? ] [ ##load-memory-imm? ] bi or ] contains-insn?
[ [ load-memory##? ] [ load-memory-imm##? ] bi or ] contains-insn?
] unit-test
{ f } [
[ 1000 [ ] times ] [ ##peek? ] contains-insn?
[ 1000 [ ] times ] [ peek##? ] contains-insn?
] unit-test
{ f t } [
[ { fixnum alien } declare <displaced-alien> 0 alien-cell ]
[ [ ##unbox-any-c-ptr? ] contains-insn? ]
[ [ ##unbox-alien? ] contains-insn? ] bi
[ [ unbox-any-c-ptr##? ] contains-insn? ]
[ [ unbox-alien##? ] contains-insn? ] bi
] unit-test
\ alien-float "intrinsic" word-prop [
[ f t ] [
[ { byte-array fixnum } declare alien-cell 4 alien-float ]
[ [ ##box-alien? ] contains-insn? ]
[ [ ##allot? ] contains-insn? ] bi
[ [ box-alien##? ] contains-insn? ]
[ [ allot##? ] contains-insn? ] bi
] unit-test
[ f t ] [
[ { byte-array fixnum } declare alien-cell { alien } declare 4 alien-float ]
[ [ ##box-alien? ] contains-insn? ]
[ [ ##allot? ] contains-insn? ] bi
[ [ box-alien##? ] contains-insn? ]
[ [ allot##? ] contains-insn? ] bi
] unit-test
[ 1 ] [ [ dup float+ ] [ ##load-memory-imm? ] count-insns ] unit-test
[ 1 ] [ [ dup float+ ] [ load-memory-imm##? ] count-insns ] unit-test
] when
! Regression. Make sure everything is inlined correctly
{ f } [ M\\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
{ f } [ M\\ hashtable set-at [ { [ call##? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test
! Regression. Make sure branch splitting works.
{ 2 } [ [ 1 2 ? ] [ ##return? ] count-insns ] unit-test
{ 2 } [ [ 1 2 ? ] [ return##? ] count-insns ] unit-test
! Make sure fast union predicates don't have conditionals.
{ f } [
[ tag 1 swap fixnum-shift-fast ]
[ ##compare-integer-imm-branch? ] contains-insn?
[ compare-integer-imm-branch##? ] contains-insn?
] unit-test
! begin-cfg
@ -253,7 +253,7 @@ SYMBOL: foo
! emit-branch
{ 77 } [
{ T{ #call { word + } } }
{ T{ call# { word + } } }
V{ } 77 insns>block
emit-branch
first predecessors>>
@ -264,7 +264,7 @@ SYMBOL: foo
! emit-call
{
V{ T{ ##call { word print } } T{ ##branch } }
V{ T{ call## { word print } } T{ branch## } }
} [
<basic-block> dup set-basic-block \ print 4 emit-call
predecessors>> first instructions>>
@ -272,13 +272,13 @@ SYMBOL: foo
! emit-if
{ V{ 3 2 } } [
<basic-block> dup set-basic-block ##branch,
T{ #if
<basic-block> dup set-basic-block branch##,
T{ if#
{ in-d { 9 } }
{ children
{
{ T{ #push { literal 3 } { out-d { 6 } } } }
{ T{ #push { literal 2 } { out-d { 7 } } } }
{ T{ push# { literal 3 } { out-d { 6 } } } }
{ T{ push# { literal 2 } { out-d { 7 } } } }
}
}
{ live-branches { t t } }
@ -295,21 +295,21 @@ SYMBOL: foo
! emit-node
! ! #call
! ! call#
{
V{
T{ ##load-integer { dst 3 } { val 0 } }
T{ ##add { dst 4 } { src1 3 } { src2 2 } }
T{ ##load-memory-imm
T{ load-integer## { dst 3 } { val 0 } }
T{ add## { dst 4 } { src1 3 } { src2 2 } }
T{ load-memory-imm##
{ dst 5 }
{ base 4 }
{ offset 0 }
{ rep int-rep }
}
T{ ##box-alien { dst 7 } { src 5 } { temp 6 } }
T{ box-alien## { dst 7 } { src 5 } { temp 6 } }
}
} [
f T{ #call
f T{ call#
{ word alien-cell }
{ in-d V{ 10 20 } }
{ out-d { 30 } }
@ -317,7 +317,7 @@ SYMBOL: foo
] cfg-unit-test
: call-node-1 ( -- node )
T{ #call
T{ call#
{ word set-slot }
{ in-d V{ 1 2 3 } }
{ out-d { } }
@ -349,7 +349,7 @@ SYMBOL: foo
} ;
{
V{ T{ ##call { word set-slot } } T{ ##branch } }
V{ T{ call## { word set-slot } } T{ branch## } }
} [
[
<basic-block> dup set-basic-block call-node-1 emit-node
@ -357,21 +357,21 @@ SYMBOL: foo
predecessors>> first instructions>>
] cfg-unit-test
! ! #push
! ! push#
{
{ T{ ##load-integer { dst 78 } { val 0 } } }
{ T{ load-integer## { dst 78 } { val 0 } } }
} [
77 vreg-counter set-global
[ f T{ #push { literal 0 } { out-d { 8537399 } } } emit-node drop ] { } make
[ f T{ push# { literal 0 } { out-d { 8537399 } } } emit-node drop ] { } make
] cfg-unit-test
! ! #shuffle
! ! shuffle#
{
T{ height-state f 0 0 1 0 }
H{ { d: -1 4 } { d: 0 4 } }
} [
4 d: 0 replace-loc
f T{ #shuffle
f T{ shuffle#
{ mapping { { 2 4 } { 3 4 } } }
{ in-d V{ 4 } }
{ out-d V{ 2 3 } }
@ -380,19 +380,19 @@ SYMBOL: foo
replaces get
] cfg-unit-test
! ! #terminate
! ! terminate#
{ f } [
<basic-block> dup set-basic-block
T{ #terminate { in-d { } } { in-r { } } } emit-node
T{ terminate# { in-d { } } { in-r { } } } emit-node
] cfg-unit-test
! end-word
{
V{
T{ ##safepoint }
T{ ##epilogue }
T{ ##return }
T{ safepoint## }
T{ epilogue## }
T{ return## }
}
} [
<basic-block> dup set-basic-block end-word instructions>>
@ -400,28 +400,28 @@ SYMBOL: foo
! height-changes
{ { -2 0 } } [
T{ #shuffle { in-d { 37 81 92 } } { out-d { 20 } } } height-changes
T{ shuffle# { in-d { 37 81 92 } } { out-d { 20 } } } height-changes
] unit-test
! make-input-map
{
{ { 37 d: 2 } { 81 d: 1 } { 92 d: 0 } }
} [
T{ #shuffle { in-d { 37 81 92 } } } make-input-map
T{ shuffle# { in-d { 37 81 92 } } } make-input-map
] unit-test
! store-shuffle
{
H{ { d: 2 1 } }
} [
f T{ #shuffle { in-d { 7 3 0 } } { out-d { 55 } } { mapping { { 55 3 } } } }
f T{ shuffle# { in-d { 7 3 0 } } { out-d { 55 } } { mapping { { 55 3 } } } }
emit-node drop replaces get
] cfg-unit-test
{
H{ { d: -1 1 } { d: 0 1 } }
} [
f T{ #shuffle
f T{ shuffle#
{ in-d { 7 } }
{ out-d { 55 77 } }
{ mapping { { 55 7 } { 77 7 } } }

84
basis/compiler/cfg/builder/builder.factor
View File

@ -37,7 +37,7 @@ GENERIC: emit-node ( block node -- block' )
: begin-word ( block -- block' )
t >>kill-block?
##safepoint, ##prologue, ##branch,
safepoint##, prologue##, branch##,
begin-basic-block ;
: (build-cfg) ( nodes word label -- )
@ -51,7 +51,7 @@ GENERIC: emit-node ( block node -- block' )
] keep ;
: emit-loop-call ( successor-block current-block -- )
##safepoint, ##branch,
safepoint##, branch##,
[ swap connect-bbs ] [ end-basic-block ] bi ;
: emit-call ( block word height -- block' )
@ -59,22 +59,22 @@ GENERIC: emit-node ( block node -- block' )
2nip swap emit-loop-call f
] [ emit-trivial-call ] if* ;
! #recursive
: recursive-height ( #recursive -- n )
! recursive#
: recursive-height ( recursive# -- n )
[ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
: emit-recursive ( block #recursive -- block' )
: emit-recursive ( block recursive# -- block' )
[ [ label>> id>> ] [ recursive-height ] bi emit-call ] keep
[ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ;
: emit-loop ( block #recursive -- block' )
##branch, [ begin-basic-block ] dip
: emit-loop ( block recursive# -- block' )
branch##, [ begin-basic-block ] dip
[ label>> id>> loops get set-at ] [ child>> emit-nodes ] 2bi ;
M: #recursive emit-node ( block node -- block' )
M: recursive# emit-node ( block node -- block' )
dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
! #if
! if#
: emit-branch ( nodes block -- pair/f )
[ swap emit-nodes ] with-branch ;
@ -83,10 +83,10 @@ M: #recursive emit-node ( block node -- block' )
: trivial-branch? ( nodes -- value ? )
dup length 1 = [
first dup #push? [ literal>> t ] [ drop f f ] if
first dup push#? [ literal>> t ] [ drop f f ] if
] [ drop f f ] if ;
: trivial-if? ( #if -- ? )
: trivial-if? ( if# -- ? )
children>> first2
[ trivial-branch? [ t eq? ] when ]
[ trivial-branch? [ f eq? ] when ] bi*
@ -95,7 +95,7 @@ M: #recursive emit-node ( block node -- block' )
: emit-trivial-if ( -- )
[ f cc/= ^^compare-imm ] unary-op ;
: trivial-not-if? ( #if -- ? )
: trivial-not-if? ( if# -- ? )
children>> first2
[ trivial-branch? [ f eq? ] when ]
[ trivial-branch? [ t eq? ] when ] bi*
@ -104,86 +104,86 @@ M: #recursive emit-node ( block node -- block' )
: emit-trivial-not-if ( -- )
[ f cc= ^^compare-imm ] unary-op ;
: emit-actual-if ( block #if -- block' )
: emit-actual-if ( block if# -- block' )
! Inputs to the final instruction need to be copied because of
! loc>vreg sync
ds-pop any-rep ^^copy f cc/= ##compare-imm-branch, emit-if ;
ds-pop any-rep ^^copy f cc/= compare-imm-branch##, emit-if ;
M: #if emit-node ( block node -- block' )
M: if# emit-node ( block node -- block' )
{
{ [ dup trivial-if? ] [ drop emit-trivial-if ] }
{ [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
[ emit-actual-if ]
} cond ;
M: #dispatch emit-node ( block node -- block' )
M: dispatch# emit-node ( block node -- block' )
! Inputs to the final instruction need to be copied because of
! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
! though.
ds-pop ^^offset>slot next-vreg ##dispatch, emit-if ;
ds-pop ^^offset>slot next-vreg dispatch##, emit-if ;
M: #call emit-node ( block node -- block' )
M: call# emit-node ( block node -- block' )
dup word>> dup "intrinsic" word-prop [
nip call( block #call -- block' )
nip call( block call# -- block' )
] [ swap call-height emit-call ] if* ;
M: #call-recursive emit-node ( block node -- block' )
M: call-recursive# emit-node ( block node -- block' )
[ label>> id>> ] [ call-height ] bi emit-call ;
M: #push emit-node ( block node -- block )
M: push# emit-node ( block node -- block )
literal>> ^^load-literal ds-push ;
! #shuffle
! shuffle#
! Even though low level IR has its own dead code elimination pass,
! we try not to introduce useless ##peeks here, since this reduces
! we try not to introduce useless peeks## here, since this reduces
! the accuracy of global stack analysis.
: make-input-map ( #shuffle -- assoc )
: make-input-map ( shuffle# -- assoc )
[ in-d>> ds-loc ] [ in-r>> rs-loc ] bi
[ over length stack-locs zip ] 2bi@ append ;
: height-changes ( #shuffle -- height-changes )
: height-changes ( shuffle# -- height-changes )
{ [ out-d>> ] [ in-d>> ] [ out-r>> ] [ in-r>> ] } cleave 4array
[ length ] map first4 [ - ] 2bi@ 2array ;
: store-height-changes ( #shuffle -- )
: store-height-changes ( shuffle# -- )
height-changes { ds-loc rs-loc } [ new swap >>n inc-stack ] 2each ;
: extract-outputs ( #shuffle -- pair )
: extract-outputs ( shuffle# -- pair )
[ out-d>> ] [ out-r>> ] bi 2array ;
: out-vregs/stack ( #shuffle -- pair )
: out-vregs/stack ( shuffle# -- pair )
[ make-input-map ] [ mapping>> ] [ extract-outputs ] tri
[ [ of of peek-loc ] 2with map ] 2with map ;
M: #shuffle emit-node ( block node -- block )
M: shuffle# emit-node ( block node -- block )
[ out-vregs/stack ] keep store-height-changes
first2 [ ds-loc store-vregs ] [ rs-loc store-vregs ] bi* ;
! #return
! return#
: end-word ( block -- block' )
##branch, begin-basic-block
branch##, begin-basic-block
t >>kill-block?
##safepoint, ##epilogue, ##return, ;
safepoint##, epilogue##, return##, ;
M: #return emit-node ( block node -- block' )
M: return# emit-node ( block node -- block' )
drop end-word ;
M: #return-recursive emit-node ( block node -- block' )
M: return-recursive# emit-node ( block node -- block' )
label>> id>> loops get key? [ ] [ end-word ] if ;
! #terminate
M: #terminate emit-node ( block node -- block' )
drop ##no-tco, end-basic-block f ;
! terminate#
M: terminate# emit-node ( block node -- block' )
drop no-tco##, end-basic-block f ;
! No-op nodes
M: #introduce emit-node drop ;
M: introduce# emit-node drop ;
M: #copy emit-node drop ;
M: copy# emit-node drop ;
M: #enter-recursive emit-node drop ;
M: enter-recursive# emit-node drop ;
M: #phi emit-node drop ;
M: phi# emit-node drop ;
M: #declare emit-node drop ;
M: declare# emit-node drop ;

4
basis/compiler/cfg/cfg-docs.factor
View File

@ -26,7 +26,7 @@ HELP: basic-block
}
{
{ $slot "kill-block?" }
{ "The first and the last block in a cfg and all blocks containing " { $link ##call } " instructions are kill blocks. Kill blocks can't be optimized so they are omitted from certain optimization steps." }
{ "The first and the last block in a cfg and all blocks containing " { $link call## } " instructions are kill blocks. Kill blocks can't be optimized so they are omitted from certain optimization steps." }
}
{
{ $slot "height" }
@ -65,7 +65,7 @@ HELP: cfg
{ { $slot "word" } { "The " { $link word } " the cfg is produced from." } }
{ { $slot "post-order" } { "The blocks of the cfg in a post order traversal " { $link sequence } "." } }
{ { $slot "stack-frame" } { { $link stack-frame } " of the cfg." } }
{ { $slot "frame-pointer?" } { "Whether the cfg needs a frame pointer. Only cfgs generated for " { $link #alien-callback } " nodes does need it. If the slot is " { $link t } ", then the frame pointer register (" { $link RBP } " on x86.64 archs) will not be clobbered by register allocation. See " { $vocab-link "compiler.cfg.linear-scan" } " for details." } }
{ { $slot "frame-pointer?" } { "Whether the cfg needs a frame pointer. Only cfgs generated for " { $link alien-callback# } " nodes does need it. If the slot is " { $link t } ", then the frame pointer register (" { $link RBP } " on x86.64 archs) will not be clobbered by register allocation. See " { $vocab-link "compiler.cfg.linear-scan" } " for details." } }
}
}
{ $see-also <cfg> post-order } ;

72
basis/compiler/cfg/copy-prop/copy-prop-tests.factor
View File

@ -8,43 +8,43 @@ IN: compiler.cfg.copy-prop.tests
! Simple example
V{
T{ ##prologue }
T{ ##branch }
T{ prologue## }
T{ branch## }
} 0 test-bb
V{
T{ ##peek f 0 d: 0 }
T{ ##branch }
T{ peek## f 0 d: 0 }
T{ branch## }
} 1 test-bb
V{
T{ ##peek f 1 d: 1 }
T{ ##branch }
T{ peek## f 1 d: 1 }
T{ branch## }
} 2 test-bb
V{
T{ ##copy f 2 0 any-rep }
T{ ##branch }
T{ copy## f 2 0 any-rep }
T{ branch## }
} 3 test-bb
V{
T{ ##phi f 3 H{ { 2 0 } { 3 2 } } }
T{ ##phi f 4 H{ { 2 1 } { 3 2 } } }
T{ ##phi f 5 H{ { 2 1 } { 3 0 } } }
T{ ##branch }
T{ phi## f 3 H{ { 2 0 } { 3 2 } } }
T{ phi## f 4 H{ { 2 1 } { 3 2 } } }
T{ phi## f 5 H{ { 2 1 } { 3 0 } } }
T{ branch## }
} 4 test-bb
V{
T{ ##copy f 6 4 any-rep }
T{ ##replace f 3 d: 0 }
T{ ##replace f 5 d: 1 }
T{ ##replace f 6 d: 2 }
T{ ##branch }
T{ copy## f 6 4 any-rep }
T{ replace## f 3 d: 0 }
T{ replace## f 5 d: 1 }
T{ replace## f 6 d: 2 }
T{ branch## }
} 5 test-bb
V{
T{ ##epilogue }
T{ ##return }
T{ epilogue## }
T{ return## }
} 6 test-bb
0 1 edge
@ -57,38 +57,38 @@ V{
{
V{
T{ ##replace f 0 d: 0 }
T{ ##replace f 4 d: 1 }
T{ ##replace f 4 d: 2 }
T{ ##branch }
T{ replace## f 0 d: 0 }
T{ replace## f 4 d: 1 }
T{ replace## f 4 d: 2 }
T{ branch## }
}
} [ 5 get instructions>> ] unit-test
! Test optimistic assumption
V{
T{ ##prologue }
T{ ##branch }
T{ prologue## }
T{ branch## }
} 0 test-bb
V{
T{ ##peek f 0 d: 0 }
T{ ##branch }
T{ peek## f 0 d: 0 }
T{ branch## }
} 1 test-bb
V{
T{ ##phi f 1 H{ { 1 0 } { 2 2 } } }
T{ ##copy f 2 1 any-rep }
T{ ##branch }
T{ phi## f 1 H{ { 1 0 } { 2 2 } } }
T{ copy## f 2 1 any-rep }
T{ branch## }
} 2 test-bb
V{
T{ ##replace f 2 d: 1 }
T{ ##branch }
T{ replace## f 2 d: 1 }
T{ branch## }
} 3 test-bb
V{
T{ ##epilogue }
T{ ##return }
T{ epilogue## }
T{ return## }
} 4 test-bb
0 1 edge
@ -100,7 +100,7 @@ V{
{
V{
T{ ##replace f 0 d: 1 }
T{ ##branch }
T{ replace## f 0 d: 1 }
T{ branch## }
}
} [ 3 get instructions>> ] unit-test

26
basis/compiler/cfg/copy-prop/copy-prop.factor
View File

@ -13,7 +13,7 @@ SYMBOL: changed?
SYMBOL: copies
! Initialized per-basic-block; a mapping from inputs to dst for
! eliminating redundant ##phi instructions
! eliminating redundant phi## instructions
SYMBOL: phis
: resolve ( vreg -- vreg )
@ -30,7 +30,7 @@ SYMBOL: phis
GENERIC: visit-insn ( insn -- )
M: ##copy visit-insn
M: copy## visit-insn
[ dst>> ] [ src>> resolve ] bi
[ record-copy ] [ drop ] if* ;
@ -41,7 +41,7 @@ M: ##copy visit-insn
: record-phi ( dst inputs -- )
[ phis get set-at ] [ drop dup record-copy ] 2bi ;
M: ##phi visit-insn
M: phi## visit-insn
[ dst>> ] [ inputs>> values [ resolve ] map ] bi
dup phis get key? [ redundant-phi ] [
dup sift
@ -72,9 +72,9 @@ M: insn visit-insn drop ;
GENERIC: update-insn ( insn -- keep? )
M: ##copy update-insn drop f ;
M: copy## update-insn drop f ;
M: ##phi update-insn
M: phi## update-insn
dup call-next-method drop
[ dst>> ] [ inputs>> values ] bi [ = not ] with any? ;
@ -96,21 +96,21 @@ PRIVATE>
! end of compiler.cfg.gvn:value-numbering).
!
! 2) At the moment in compiler.cfg.gvn:value-numbering,
! ##phis with equivalent inputs (i.e., identical value
! numbers) will be converted into ##copy insns; thus, some
! ##copies may show up *before* ##phis within a basic block,
! even though ##phis should come at the very beginning of a
! phis## with equivalent inputs (i.e., identical value
! numbers) will be converted into copy## insns; thus, some
! copies## may show up *before* phis## within a basic block,
! even though phis## should come at the very beginning of a
! block.
!
! Thus, the call to needs-predecessors in copy-propagation may
! wind up failing to prune dead inputs to particular ##phis in
! a block (if they're preceded by ##copies). However,
! copy-propagation will remove the ##copies that
! wind up failing to prune dead inputs to particular phis## in
! a block (if they're preceded by copies##). However,
! copy-propagation will remove the copies## that
! value-numbering introduces. So, a band-aid solution is to
! suffix a predecessors-changed to copy-propagation, so that
! future calls to needs-predecessors (particularly in
! compiler.cfg.dce:eliminate-dead-code) will finally correct
! the ##phi nodes left over after value-numbering.
! the phi## nodes left over after value-numbering.
!
! A better solution (and the eventual goal) would be to have
! value-numbering subsume copy-propagation, thus eliminating

72
basis/compiler/cfg/dce/dce-tests.factor
View File

@ -8,62 +8,62 @@ IN: compiler.cfg.dce.tests
insns>cfg dup eliminate-dead-code entry>> instructions>> ;
{ V{
T{ ##load-integer { dst 1 } { val 8 } }
T{ ##load-integer { dst 2 } { val 16 } }
T{ ##add { dst 3 } { src1 1 } { src2 2 } }
T{ ##replace { src 3 } { loc d: 0 } }
T{ load-integer## { dst 1 } { val 8 } }
T{ load-integer## { dst 2 } { val 16 } }
T{ add## { dst 3 } { src1 1 } { src2 2 } }
T{ replace## { src 3 } { loc d: 0 } }
} } [ V{
T{ ##load-integer { dst 1 } { val 8 } }
T{ ##load-integer { dst 2 } { val 16 } }
T{ ##add { dst 3 } { src1 1 } { src2 2 } }
T{ ##replace { src 3 } { loc d: 0 } }
T{ load-integer## { dst 1 } { val 8 } }
T{ load-integer## { dst 2 } { val 16 } }
T{ add## { dst 3 } { src1 1 } { src2 2 } }
T{ replace## { src 3 } { loc d: 0 } }
} test-dce ] unit-test
{ V{ } } [ V{
T{ ##load-integer { dst 1 } { val 8 } }
T{ ##load-integer { dst 2 } { val 16 } }
T{ ##add { dst 3 } { src1 1 } { src2 2 } }
T{ load-integer## { dst 1 } { val 8 } }
T{ load-integer## { dst 2 } { val 16 } }
T{ add## { dst 3 } { src1 1 } { src2 2 } }
} test-dce ] unit-test
{ V{ } } [ V{
T{ ##load-integer { dst 3 } { val 8 } }
T{ ##allot { dst 1 } { temp 2 } }
T{ load-integer## { dst 3 } { val 8 } }
T{ allot## { dst 1 } { temp 2 } }
} test-dce ] unit-test
{ V{ } } [ V{
T{ ##load-integer { dst 3 } { val 8 } }
T{ ##allot { dst 1 } { temp 2 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
T{ load-integer## { dst 3 } { val 8 } }
T{ allot## { dst 1 } { temp 2 } }
T{ set-slot-imm## { obj 1 } { src 3 } }
} test-dce ] unit-test
{ V{
T{ ##load-integer { dst 3 } { val 8 } }
T{ ##allot { dst 1 } { temp 2 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
T{ ##replace { src 1 } { loc d: 0 } }
T{ load-integer## { dst 3 } { val 8 } }
T{ allot## { dst 1 } { temp 2 } }
T{ set-slot-imm## { obj 1 } { src 3 } }
T{ replace## { src 1 } { loc d: 0 } }
} } [ V{
T{ ##load-integer { dst 3 } { val 8 } }
T{ ##allot { dst 1 } { temp 2 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
T{ ##replace { src 1 } { loc d: 0 } }
T{ load-integer## { dst 3 } { val 8 } }
T{ allot## { dst 1 } { temp 2 } }
T{ set-slot-imm## { obj 1 } { src 3 } }
T{ replace## { src 1 } { loc d: 0 } }
} test-dce ] unit-test
{ V{
T{ ##allot { dst 1 } { temp 2 } }
T{ ##replace { src 1 } { loc d: 0 } }
T{ allot## { dst 1 } { temp 2 } }
T{ replace## { src 1 } { loc d: 0 } }
} } [ V{
T{ ##allot { dst 1 } { temp 2 } }
T{ ##replace { src 1 } { loc d: 0 } }
T{ allot## { dst 1 } { temp 2 } }
T{ replace## { src 1 } { loc d: 0 } }
} test-dce ] unit-test
{ V{
T{ ##allot { dst 1 } { temp 2 } }
T{ ##replace { src 1 } { loc d: 0 } }
T{ ##load-integer { dst 3 } { val 8 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
T{ allot## { dst 1 } { temp 2 } }
T{ replace## { src 1 } { loc d: 0 } }
T{ load-integer## { dst 3 } { val 8 } }
T{ set-slot-imm## { obj 1 } { src 3 } }
} } [ V{
T{ ##allot { dst 1 } { temp 2 } }
T{ ##replace { src 1 } { loc d: 0 } }
T{ ##load-integer { dst 3 } { val 8 } }
T{ ##set-slot-imm { obj 1 } { src 3 } }
T{ allot## { dst 1 } { temp 2 } }
T{ replace## { src 1 } { loc d: 0 } }
T{ load-integer## { dst 3 } { val 8 } }
T{ set-slot-imm## { obj 1 } { src 3 } }
} test-dce ] unit-test

28
basis/compiler/cfg/dce/dce.factor
View File

@ -33,19 +33,19 @@ GENERIC: build-liveness-graph ( insn -- )
: setter-liveness-graph ( insn vreg -- )
dup allocation? [ [ uses-vregs ] dip add-edges ] [ 2drop ] if ;
M: ##set-slot build-liveness-graph
M: set-slot## build-liveness-graph
dup obj>> setter-liveness-graph ;
M: ##set-slot-imm build-liveness-graph
M: set-slot-imm## build-liveness-graph
dup obj>> setter-liveness-graph ;
M: ##write-barrier build-liveness-graph
M: write-barrier## build-liveness-graph
dup src>> setter-liveness-graph ;
M: ##write-barrier-imm build-liveness-graph
M: write-barrier-imm## build-liveness-graph
dup src>> setter-liveness-graph ;
M: ##allot build-liveness-graph
M: allot## build-liveness-graph
[ dst>> allocations get adjoin ] [ call-next-method ] bi ;
M: vreg-insn build-liveness-graph
@ -68,16 +68,16 @@ GENERIC: compute-live-vregs ( insn -- )
: setter-live-vregs ( insn vreg -- )
allocation? [ drop ] [ record-live ] if ;
M: ##set-slot compute-live-vregs
M: set-slot## compute-live-vregs
dup obj>> setter-live-vregs ;
M: ##set-slot-imm compute-live-vregs
M: set-slot-imm## compute-live-vregs
dup obj>> setter-live-vregs ;
M: ##write-barrier compute-live-vregs
M: write-barrier## compute-live-vregs
dup src>> setter-live-vregs ;
M: ##write-barrier-imm compute-live-vregs
M: write-barrier-imm## compute-live-vregs
dup src>> setter-live-vregs ;
M: flushable-insn compute-live-vregs drop ;
@ -88,13 +88,13 @@ M: insn compute-live-vregs drop ;
GENERIC: live-insn? ( insn -- ? )
M: ##set-slot live-insn? obj>> live-vreg? ;
M: set-slot## live-insn? obj>> live-vreg? ;
M: ##set-slot-imm live-insn? obj>> live-vreg? ;
M: set-slot-imm## live-insn? obj>> live-vreg? ;
M: ##write-barrier live-insn? src>> live-vreg? ;
M: write-barrier## live-insn? src>> live-vreg? ;
M: ##write-barrier-imm live-insn? src>> live-vreg? ;
M: write-barrier-imm## live-insn? src>> live-vreg? ;
: filter-alien-outputs ( outputs -- live-outputs dead-outputs )
[ first live-vreg? ] partition
@ -104,7 +104,7 @@ M: alien-call-insn live-insn?
dup reg-outputs>> filter-alien-outputs [ >>reg-outputs ] [ >>dead-outputs ] bi*
drop t ;
M: ##callback-inputs live-insn?
M: callback-inputs## live-insn?
[ filter-alien-outputs drop ] change-reg-outputs
[ filter-alien-outputs drop ] change-stack-outputs
drop t ;

2
basis/compiler/cfg/debugger/debugger.factor
View File

@ -41,7 +41,7 @@ M: word test-builder
GENERIC: insn. ( insn -- )
M: ##phi insn.
M: phi## insn.
clone [ [ [ number>> ] dip ] assoc-map ] change-inputs
call-next-method ;

4
basis/compiler/cfg/def-use/def-use-docs.factor
View File

@ -19,7 +19,7 @@ HELP: defs-vregs
{ $examples
{ $example
"USING: compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.registers prettyprint ;"
"T{ ##peek f 37 d: 0 0 } defs-vregs ."
"T{ peek## f 37 d: 0 0 } defs-vregs ."
"{ 37 }"
}
}
@ -44,7 +44,7 @@ HELP: uses-vregs
{ $examples
{ $example
"USING: compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.registers prettyprint ;"
"T{ ##replace f 37 d: 1 6 } uses-vregs ."
"T{ replace## f 37 d: 1 6 } uses-vregs ."
"{ 37 }"
}
} ;

16
basis/compiler/cfg/def-use/def-use-tests.factor
View File

@ -7,30 +7,30 @@ IN: compiler.cfg.def-use.tests
! compute-insns
{
T{ ##peek f 123 d: 0 f }
T{ peek## f 123 d: 0 f }
} [
{ T{ ##peek f 123 d: 0 } } 0 insns>block block>cfg compute-insns
{ T{ peek## f 123 d: 0 } } 0 insns>block block>cfg compute-insns
123 insn-of
] unit-test
V{
T{ ##peek f 0 d: 0 }
T{ ##peek f 1 d: 0 }
T{ ##peek f 2 d: 0 }
T{ peek## f 0 d: 0 }
T{ peek## f 1 d: 0 }
T{ peek## f 2 d: 0 }
} 1 test-bb
V{
T{ ##replace f 2 d: 0 }
T{ replace## f 2 d: 0 }
} 2 test-bb
1 2 edge
V{
T{ ##replace f 0 d: 0 }
T{ replace## f 0 d: 0 }
} 3 test-bb
2 3 edge
V{ } 4 test-bb
V{ } 5 test-bb
3 { 4 5 } edges
V{
T{ ##phi f 2 H{ { 2 0 } { 3 1 } } }
T{ phi## f 2 H{ { 2 0 } { 3 1 } } }
} 6 test-bb
4 6 edge
5 6 edge

32
basis/compiler/cfg/def-use/def-use.factor
View File

@ -17,43 +17,43 @@ M: insn temp-vregs drop { } ;
M: insn uses-vregs drop { } ;
CONSTANT: special-vreg-insns {
##parallel-copy
##phi
##alien-invoke
##alien-indirect
##alien-assembly
##callback-inputs
##callback-outputs
parallel-copy##
phi##
alien-invoke##
alien-indirect##
alien-assembly##
callback-inputs##
callback-outputs##
}
! Special defs-vregs methods
M: ##parallel-copy defs-vregs values>> [ first ] map ;
M: parallel-copy## defs-vregs values>> [ first ] map ;
M: ##phi defs-vregs dst>> 1array ;
M: phi## defs-vregs dst>> 1array ;
M: alien-call-insn defs-vregs
reg-outputs>> [ first ] map ;
M: ##callback-inputs defs-vregs
M: callback-inputs## defs-vregs
[ reg-outputs>> ] [ stack-outputs>> ] bi append [ first ] map ;
M: ##callback-outputs defs-vregs drop { } ;
M: callback-outputs## defs-vregs drop { } ;
! Special uses-vregs methods
M: ##parallel-copy uses-vregs values>> [ second ] map ;
M: parallel-copy## uses-vregs values>> [ second ] map ;
M: ##phi uses-vregs inputs>> values ;
M: phi## uses-vregs inputs>> values ;
M: alien-call-insn uses-vregs
[ reg-inputs>> ] [ stack-inputs>> ] bi append [ first ] map ;
M: ##alien-indirect uses-vregs
M: alien-indirect## uses-vregs
[ call-next-method ] [ src>> ] bi prefix ;
M: ##callback-inputs uses-vregs
M: callback-inputs## uses-vregs
drop { } ;
M: ##callback-outputs uses-vregs
M: callback-outputs## uses-vregs
reg-inputs>> [ first ] map ;
! Generate defs-vregs, uses-vregs and temp-vregs for everything

2
basis/compiler/cfg/gc-checks/gc-checks-docs.factor
View File

@ -29,7 +29,7 @@ HELP: blocks-with-gc
HELP: gc-check-offsets
{ $values { "insns" sequence } { "seq" sequence } }
{ $description "A basic block is divided into sections by " { $link ##call } " and " { $link ##phi } " instructions. For every section with at least one allocation, record the offset of its first instruction in a sequence." } ;
{ $description "A basic block is divided into sections by " { $link call## } " and " { $link phi## } " instructions. For every section with at least one allocation, record the offset of its first instruction in a sequence." } ;
HELP: insert-gc-check?
{ $values { "bb" basic-block } { "?" boolean } }

222
basis/compiler/cfg/gc-checks/gc-checks-tests.factor
View File

@ -8,18 +8,18 @@ IN: compiler.cfg.gc-checks.tests
! insert-gc-check?
{ t f } [
V{ T{ ##inc } T{ ##allot } } 0 insns>block insert-gc-check?
V{ T{ ##call } } 0 insns>block insert-gc-check?
V{ T{ inc## } T{ allot## } } 0 insns>block insert-gc-check?
V{ T{ call## } } 0 insns>block insert-gc-check?
] unit-test
! allocation-size
{ t } [
V{ T{ ##box-alien f 0 1 } } allocation-size
V{ T{ box-alien## f 0 1 } } allocation-size
123 <alien> size =
] unit-test
{ t } [
V{ T{ ##box-alien } T{ ##replace } } allocation-size
V{ T{ box-alien## } T{ replace## } } allocation-size
5 cells data-alignment get align =
] unit-test
@ -27,10 +27,10 @@ IN: compiler.cfg.gc-checks.tests
{
{
V{
T{ ##inc }
T{ ##peek }
T{ ##alien-invoke }
T{ ##check-nursery-branch
T{ inc## }
T{ peek## }
T{ alien-invoke## }
T{ check-nursery-branch##
{ size 64 }
{ cc cc<= }
{ temp1 1 }
@ -38,26 +38,26 @@ IN: compiler.cfg.gc-checks.tests
}
}
V{
T{ ##allot
T{ allot##
{ dst 1 }
{ size 64 }
{ class-of byte-array }
}
T{ ##add }
T{ ##branch }
T{ add## }
T{ branch## }
}
}
} [
{
V{ T{ ##inc } T{ ##peek } T{ ##alien-invoke } }
V{ T{ inc## } T{ peek## } T{ alien-invoke## } }
V{
T{ ##allot
T{ allot##
{ dst 1 }
{ size 64 }
{ class-of byte-array }
}
T{ ##add }
T{ ##branch }
T{ add## }
T{ branch## }
}
} [ add-gc-checks ] keep
] cfg-unit-test
@ -65,66 +65,66 @@ IN: compiler.cfg.gc-checks.tests
! gc-check-offsets
{ { } } [
V{
T{ ##inc }
T{ ##peek }
T{ ##add }
T{ ##branch }
T{ inc## }
T{ peek## }
T{ add## }
T{ branch## }
} gc-check-offsets
] unit-test
{ { } } [
V{
T{ ##inc }
T{ ##peek }
T{ ##alien-invoke }
T{ ##add }
T{ ##branch }
T{ inc## }
T{ peek## }
T{ alien-invoke## }
T{ add## }
T{ branch## }
} gc-check-offsets
] unit-test
{ { 0 } } [
V{
T{ ##inc }
T{ ##peek }
T{ ##allot }
T{ ##alien-invoke }
T{ ##add }
T{ ##branch }
T{ inc## }
T{ peek## }
T{ allot## }
T{ alien-invoke## }
T{ add## }
T{ branch## }
} gc-check-offsets
] unit-test
{ { 0 } } [
V{
T{ ##inc }
T{ ##peek }
T{ ##allot }
T{ ##allot }
T{ ##add }
T{ ##branch }
T{ inc## }
T{ peek## }
T{ allot## }
T{ allot## }
T{ add## }
T{ branch## }
} gc-check-offsets
] unit-test
{ { 0 4 } } [
V{
T{ ##inc }
T{ ##peek }
T{ ##allot }
T{ ##alien-invoke }
T{ ##allot }
T{ ##add }
T{ ##sub }
T{ ##branch }
T{ inc## }
T{ peek## }
T{ allot## }
T{ alien-invoke## }
T{ allot## }
T{ add## }
T{ sub## }
T{ branch## }
} gc-check-offsets
] unit-test
{ { 3 } } [
V{
T{ ##inc }
T{ ##peek }
T{ ##alien-invoke }
T{ ##allot }
T{ ##add }
T{ ##branch }
T{ inc## }
T{ peek## }
T{ alien-invoke## }
T{ allot## }
T{ add## }
T{ branch## }
} gc-check-offsets
] unit-test
@ -143,12 +143,12 @@ IN: compiler.cfg.gc-checks.tests
0 get block>cfg cfg set ;
V{
T{ ##inc f 3 }
T{ ##replace f 0 d: 1 }
T{ inc## f 3 }
T{ replace## f 0 d: 1 }
} 0 test-bb
V{
T{ ##box-alien f 0 1 }
T{ box-alien## f 0 1 }
} 1 test-bb
0 1 edge
@ -161,14 +161,14 @@ V{
instructions>>
{
[ length 1 = ]
[ first ##check-nursery-branch? ]
[ first check-nursery-branch##? ]
} 1&& ;
: gc-call? ( bb -- ? )
instructions>>
V{
T{ ##call-gc f T{ gc-map } }
T{ ##branch }
T{ call-gc## f T{ gc-map } }
T{ branch## }
} = ;
{ t } [ <gc-call> gc-call? ] unit-test
@ -176,33 +176,33 @@ V{
reset-vreg-counter
V{
T{ ##prologue }
T{ ##branch }
T{ prologue## }
T{ branch## }
} 0 test-bb
V{
T{ ##peek f 2 d: 0 }
T{ ##inc { loc d: 3 } }
T{ ##branch }
T{ peek## f 2 d: 0 }
T{ inc## { loc d: 3 } }
T{ branch## }
} 1 test-bb
V{
T{ ##allot f 1 64 byte-array }
T{ ##branch }
T{ allot## f 1 64 byte-array }
T{ branch## }
} 2 test-bb
V{
T{ ##branch }
T{ branch## }
} 3 test-bb
V{
T{ ##replace f 2 d: 1 }
T{ ##branch }
T{ replace## f 2 d: 1 }
T{ branch## }
} 4 test-bb
V{
T{ ##epilogue }
T{ ##return }
T{ epilogue## }
T{ return## }
} 5 test-bb
0 1 edge
@ -231,33 +231,33 @@ H{
{
V{
T{ ##call-gc f T{ gc-map } }
T{ ##branch }
T{ call-gc## f T{ gc-map } }
T{ branch## }
}
} [ 2 get predecessors>> second instructions>> ] unit-test
! Don't forget to invalidate RPO after inserting basic blocks!
{ 8 } [ cfg get reverse-post-order length ] unit-test
! Do the right thing with ##phi instructions
! Do the right thing with phi## instructions
V{
T{ ##branch }
T{ branch## }
} 0 test-bb
V{
T{ ##load-reference f 1 "hi" }
T{ ##branch }
T{ load-reference## f 1 "hi" }
T{ branch## }
} 1 test-bb
V{
T{ ##load-reference f 2 "bye" }
T{ ##branch }
T{ load-reference## f 2 "bye" }
T{ branch## }
} 2 test-bb
V{
T{ ##phi f 3 H{ { 1 1 } { 2 2 } } }
T{ ##allot f 1 64 byte-array }
T{ ##branch }
T{ phi## f 3 H{ { 1 1 } { 2 2 } } }
T{ allot## f 1 64 byte-array }
T{ branch## }
} 3 test-bb
0 { 1 2 } edges
@ -274,23 +274,23 @@ H{
{ } [ cfg get insert-gc-checks ] unit-test
{ } [ 1 get successors>> first successors>> first 3 set ] unit-test
{ t } [ 2 get successors>> first instructions>> first ##phi? ] unit-test
{ t } [ 2 get successors>> first instructions>> first phi##? ] unit-test
{ 2 } [ 3 get instructions>> length ] unit-test
! GC check in a block that is its own successor
V{
T{ ##prologue }
T{ ##branch }
T{ prologue## }
T{ branch## }
} 0 test-bb
V{
T{ ##allot f 1 64 byte-array }
T{ ##branch }
T{ allot## f 1 64 byte-array }
T{ branch## }
} 1 test-bb
V{
T{ ##epilogue }
T{ ##return }
T{ epilogue## }
T{ return## }
} 2 test-bb
0 1 edge
@ -322,19 +322,19 @@ V{
! call then allot
V{
T{ ##prologue }
T{ ##branch }
T{ prologue## }
T{ branch## }
} 0 test-bb
V{
T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
T{ ##allot f 1 64 byte-array }
T{ ##branch }
T{ alien-invoke## f "malloc" f f f f f T{ gc-map } }
T{ allot## f 1 64 byte-array }
T{ branch## }
} 1 test-bb
V{
T{ ##epilogue }
T{ ##return }
T{ epilogue## }
T{ return## }
} 2 test-bb
0 1 edge
@ -349,28 +349,28 @@ V{
! The GC check should come after the alien-invoke
{
V{
T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
T{ ##check-nursery-branch f 64 cc<= 3 4 }
T{ alien-invoke## f "malloc" f f f f f T{ gc-map } }
T{ check-nursery-branch## f 64 cc<= 3 4 }
}
} [ 0 get successors>> first instructions>> ] unit-test
! call then allot then call then allot
V{
T{ ##prologue }
T{ ##branch }
T{ prologue## }
T{ branch## }
} 0 test-bb
V{
T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
T{ ##allot f 1 64 byte-array }
T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
T{ ##allot f 2 64 byte-array }
T{ ##branch }
T{ alien-invoke## f "malloc" f f f f f T{ gc-map } }
T{ allot## f 1 64 byte-array }
T{ alien-invoke## f "malloc" f f f f f T{ gc-map } }
T{ allot## f 2 64 byte-array }
T{ branch## }
} 1 test-bb
V{
T{ ##epilogue }
T{ ##return }
T{ epilogue## }
T{ return## }
} 2 test-bb
0 1 edge
@ -384,8 +384,8 @@ V{
{
V{
T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
T{ ##check-nursery-branch f 64 cc<= 3 4 }
T{ alien-invoke## f "malloc" f f f f f T{ gc-map } }
T{ check-nursery-branch## f 64 cc<= 3 4 }
}
} [
0 get
@ -395,9 +395,9 @@ V{
{
V{
T{ ##allot f 1 64 byte-array }
T{ ##alien-invoke f "malloc" f f f f f T{ gc-map } }
T{ ##check-nursery-branch f 64 cc<= 5 6 }
T{ allot## f 1 64 byte-array }
T{ alien-invoke## f "malloc" f f f f f T{ gc-map } }
T{ check-nursery-branch## f 64 cc<= 5 6 }
}
} [
0 get
@ -408,8 +408,8 @@ V{
{
V{
T{ ##allot f 2 64 byte-array }
T{ ##branch }
T{ allot## f 2 64 byte-array }
T{ branch## }
}
} [
0 get

14
basis/compiler/cfg/gc-checks/gc-checks.factor
View File

@ -22,8 +22,8 @@ GENERIC#: gc-check-offsets* 1 ( call-index seen-allocation? insn n -- call-index
seen-allocation? [ call-index , ] when
insn-index 1 + f ;
M: ##callback-inputs gc-check-offsets* gc-check-here ;
M: ##phi gc-check-offsets* gc-check-here ;
M: callback-inputs## gc-check-offsets* gc-check-here ;
M: phi## gc-check-offsets* gc-check-here ;
M: gc-map-insn gc-check-offsets* gc-check-here ;
M: allocation-insn gc-check-offsets* 3drop t ;
M: insn gc-check-offsets* 2drop ;
@ -48,9 +48,9 @@ M: insn gc-check-offsets* 2drop ;
GENERIC: allocation-size* ( insn -- n )
M: ##allot allocation-size* size>> ;
M: ##box-alien allocation-size* drop 5 cells ;
M: ##box-displaced-alien allocation-size* drop 5 cells ;
M: allot## allocation-size* size>> ;
M: box-alien## allocation-size* drop 5 cells ;
M: box-displaced-alien## allocation-size* drop 5 cells ;
: allocation-size ( insns -- n )
[ allocation-insn? ] filter
@ -60,7 +60,7 @@ M: ##box-displaced-alien allocation-size* drop 5 cells ;
2 <clumps> [
first2 allocation-size
cc<= int-rep next-vreg-rep int-rep next-vreg-rep
##check-nursery-branch new-insn
check-nursery-branch## new-insn
swap push
] each ;
@ -69,7 +69,7 @@ M: ##box-displaced-alien allocation-size* drop 5 cells ;
: <gc-call> ( -- bb )
<basic-block>
[ <gc-map> ##call-gc, ##branch, ] V{ } make
[ <gc-map> call-gc##, branch##, ] V{ } make
>>instructions ;
:: connect-gc-checks ( bbs -- )

2
basis/compiler/cfg/hats/hats-tests.factor
View File

@ -3,7 +3,7 @@ compiler.cfg.registers make tools.test ;
IN: compiler.cfg.hats.tests
{
1 V{ T{ ##local-allot { dst 1 } { size 32 } { align 8 } } }
1 V{ T{ local-allot## { dst 1 } { size 32 } { align 8 } } }
} [
reset-vreg-counter [ 32 8 f ^^local-allot ] V{ } make
] unit-test

4
basis/compiler/cfg/hats/hats.factor
View File

@ -11,7 +11,7 @@ IN: compiler.cfg.hats
<PRIVATE
: hat-name ( insn -- word )
name>> "##" ?head drop "^^" prepend create-word-in ;
name>> "##" ?tail drop "^^" prepend create-word-in ;
: hat-quot ( insn -- quot )
[
@ -35,7 +35,7 @@ IN: compiler.cfg.hats
PRIVATE>
insn-classes get [
dup [ insn-def-slots length 1 = ] [ name>> "##" head? ] bi and
dup [ insn-def-slots length 1 = ] [ name>> "##" tail? ] bi and
[ define-hat ] [ drop ] if
] each

316
basis/compiler/cfg/instructions/instructions-docs.factor
View File

@ -6,7 +6,7 @@ compiler.codegen.gc-maps compiler.tree cpu.architecture help.markup
help.syntax kernel layouts math sequences slots.private system vm ;
IN: compiler.cfg.instructions
HELP: ##alien-invoke
HELP: alien-invoke##
{ $class-description
"An instruction for calling a function in a dynamically linked library. It has the following slots:"
{ $table
@ -39,9 +39,9 @@ HELP: ##alien-invoke
}
"Which function arguments that goes in " { $slot "reg-inputs" } " and which goes in " { $slot "stack-inputs" } " depend on the calling convention. In " { $link cdecl } " on " { $link x86.32 } ", all arguments goes in " { $slot "stack-inputs" } ", in " { $link x86.64 } " on " { $link unix } ", the first six arguments are passed in registers and then stack parameters are used for the remainder."
}
{ $see-also #alien-invoke %alien-invoke } ;
{ $see-also alien-invoke# %alien-invoke } ;
HELP: ##alien-indirect
HELP: alien-indirect##
{ $class-description
"An instruction representing an indirect alien call. The first item on the datastack is a pointer to the function to call and the parameters follows. It has the following slots:"
{ $table
@ -51,9 +51,9 @@ HELP: ##alien-indirect
}
{ $see-also alien-indirect %alien-indirect } ;
HELP: ##allot
HELP: allot##
{ $class-description
"An instruction for allocating memory in the nursery. Usually the instruction is preceded by " { $link ##check-nursery-branch } " which checks that there is enough room in the nursery to allocate. It has the following slots:"
"An instruction for allocating memory in the nursery. Usually the instruction is preceded by " { $link check-nursery-branch## } " which checks that there is enough room in the nursery to allocate. It has the following slots:"
{ $table
{ { $slot "dst" } { "Register to put the pointer to the memory in." } }
{ { $slot "size" } { "Number of bytes to allocate." } }
@ -62,21 +62,21 @@ HELP: ##allot
}
} ;
HELP: ##bit-count
HELP: bit-count##
{ $class-description "Specialized instruction for counting the number of lit bits in an integer." }
{ $see-also %bit-count } ;
HELP: ##box
HELP: box##
{ $class-description
"This instruction boxes a value into a tagged pointer."
} { $see-also %box } ;
HELP: ##box-alien
HELP: box-alien##
{ $class-description
"An instruction for boxing an alien value."
} ;
HELP: ##call
HELP: call##
{ $class-description
"An instruction for calling a Factor word."
{ $table
@ -84,7 +84,7 @@ HELP: ##call
}
} ;
HELP: ##check-nursery-branch
HELP: check-nursery-branch##
{ $class-description
"Instruction that inserts a conditional branch to a " { $link basic-block } " that garbage collects the nursery. The " { $vocab-link "compiler.cfg.gc-checks" } " vocab goes through each block in the " { $link cfg } " and checks if it allocates memory. If it does, then this instruction is inserted in the cfg before that block and checks if there is enough available space in the nursery. If it isn't, then a basic block containing code for garbage collecting the nursery is executed."
$nl
@ -98,7 +98,7 @@ HELP: ##check-nursery-branch
}
{ $see-also %check-nursery-branch } ;
HELP: ##compare-float-ordered-branch
HELP: compare-float-ordered-branch##
{ $class-description
"It has the following slots:"
{ $table
@ -106,54 +106,54 @@ HELP: ##compare-float-ordered-branch
}
} ;
HELP: ##compare-imm
HELP: compare-imm##
{ $class-description "Instruction used to implement trivial ifs and not ifs." }
{ $see-also emit-trivial-if emit-trivial-not-if } ;
HELP: ##compare-imm-branch
HELP: compare-imm-branch##
{ $class-description "The instruction used to implement branching for the " { $link if } " word." } ;
HELP: ##compare-integer
HELP: compare-integer##
{ $class-description "This instruction is emitted for " { $link fixnum } " comparisons." }
{ $see-also emit-fixnum-comparison } ;
HELP: ##copy
HELP: copy##
{ $class-description "Instruction that copies a value from one register to another of the same type. For example, you can copy between two gprs or two simd registers but not across. It has the following slots:"
{ $table
{ { $slot "rep" } { "Value representation. Both the source and destination register must have the same representation." } }
}
} ;
HELP: ##dispatch
HELP: dispatch##
{ $class-description "Special instruction for implementing " { $link case } " blocks." } ;
HELP: ##fixnum-add
HELP: fixnum-add##
{ $class-description "Instruction for adding two fixnums together." }
{ $see-also emit-fixnum+ } ;
HELP: ##inc
HELP: inc##
{ $class-description
"An instruction that increases or decreases a stacks height by n. For example, " { $link 2drop } " decreases the datastacks height by two and pushing an item increases it by one."
} ;
HELP: ##jump
HELP: jump##
{ $class-description
"An uncondiation jump instruction. It has the following slots:"
{ $table
{ { $slot "word" } { "Word whose address the instruction is jumping to." } }
}
"Note that the optimizer is sometimes able to optimize away a " { $link ##call } " and " { $link ##return } " pair into one ##jump instruction."
"Note that the optimizer is sometimes able to optimize away a " { $link call## } " and " { $link return## } " pair into one jump## instruction."
} ;
HELP: ##load-double
HELP: load-double##
{ $class-description "Loads a " { $link float } " into a SIMD register." }
{ $see-also %load-double } ;
HELP: ##load-memory-imm
HELP: load-memory-imm##
{ $class-description "Instruction for loading data from memory into a register. Either a General Purpose or an SSE register." }
{ $see-also %load-memory-imm } ;
HELP: ##load-reference
HELP: load-reference##
{ $class-description
"An instruction for loading a pointer to an object into a register. It has the following slots:"
{ $table
@ -162,16 +162,16 @@ HELP: ##load-reference
}
} ;
HELP: ##load-tagged
HELP: load-tagged##
{ $class-description "Loads a tagged value into a register." } ;
HELP: ##load-vector
HELP: load-vector##
{ $class-description
"Loads a " { $link byte-array } " into an SSE register."
}
{ $see-also %load-vector } ;
HELP: ##local-allot
HELP: local-allot##
{ $class-description
"An instruction for allocating memory in the words own stack frame. It's mostly used for receiving data from alien calls. It has the following slots:"
{ $table
@ -180,29 +180,29 @@ HELP: ##local-allot
{ { $slot "offset" } { } }
}
}
{ $see-also ##allot } ;
{ $see-also allot## } ;
HELP: ##mul-vector
HELP: mul-vector##
{ $class-description
"SIMD instruction." } ;
HELP: ##no-tco
HELP: no-tco##
{ $class-description "A dummy instruction that simply inhibits TCO." } ;
HELP: ##parallel-copy
{ $class-description "An instruction for performing multiple copies. It allows for optimizations or (or prunings) if more than one source or destination vreg is the same. They are transformed into " { $link ##copy } " instructions in " { $link destruct-ssa } ". It has the following slots:"
HELP: parallel-copy##
{ $class-description "An instruction for performing multiple copies. It allows for optimizations or (or prunings) if more than one source or destination vreg is the same. They are transformed into " { $link copy## } " instructions in " { $link destruct-ssa } ". It has the following slots:"
{ $table
{ { $slot "values" } { "An assoc mapping source vregs to destinations." } }
}
} ;
HELP: ##peek
HELP: peek##
{ $class-description
"Copies a value from a stack location to a machine register."
}
{ $see-also ##replace } ;
{ $see-also replace## } ;
HELP: ##phi
HELP: phi##
{ $class-description
"A special kind of instruction used to mark control flow. It is inserted by the " { $vocab-link "compiler.cfg.ssa.construction" } " vocab. It has the following slots:"
{ $table
@ -211,34 +211,34 @@ HELP: ##phi
}
} ;
HELP: ##prologue
HELP: prologue##
{ $class-description
"An instruction for generating the prologue for a cfg. All it does is decrementing the stack register a number of cells to give the generated code some stack space to work with." }
{ $see-also ##epilogue } ;
{ $see-also epilogue## } ;
HELP: ##reload
HELP: reload##
{ $class-description "Instruction that copies a value from a " { $link spill-slot } " to a register." } ;
HELP: ##replace
HELP: replace##
{ $class-description "Copies a value from a machine register to a stack location." }
{ $see-also ##peek ##replace-imm } ;
{ $see-also peek## replace-imm## } ;
HELP: ##replace-imm
{ $class-description "An instruction that replaces an item on the data or register stack with an " { $link immediate } " value. The " { $link value-numbering } " compiler optimization pass can sometimes rewrite " { $link ##replace } " instructions to ##replace-imm's." }
{ $see-also ##replace } ;
HELP: replace-imm##
{ $class-description "An instruction that replaces an item on the data or register stack with an " { $link immediate } " value. The " { $link value-numbering } " compiler optimization pass can sometimes rewrite " { $link replace## } " instructions to replace-imm##'s." }
{ $see-also replace## } ;
HELP: ##return
HELP: return##
{ $class-description "Instruction that returns from a procedure call." } ;
HELP: ##safepoint
HELP: safepoint##
{ $class-description "Instruction that inserts a safe point in the generated code." } ;
HELP: ##save-context
{ $class-description "The ##save-context instructions saves the state of the data, retain and callstacks in the threads " { $link context } " struct." }
HELP: save-context##
{ $class-description "The save-context## instructions saves the state of the data, retain and callstacks in the threads " { $link context } " struct." }
{ $see-also %save-context } ;
HELP: ##set-slot
HELP: set-slot##
{ $class-description
"An instruction for the non-primitive, non-immediate variant of " { $link set-slot } ". It has the following slots:"
{ $table
@ -249,7 +249,7 @@ HELP: ##set-slot
}
} ;
HELP: ##set-slot-imm
HELP: set-slot-imm##
{ $class-description
"An instruction for what? It has the following slots:"
{ $table
@ -259,14 +259,14 @@ HELP: ##set-slot-imm
{ { $slot "tag" } { "Type tag for obj." } }
}
}
{ $see-also ##set-slot %set-slot-imm } ;
{ $see-also set-slot## %set-slot-imm } ;
{ ##set-slot-imm ##set-slot } related-words
{ set-slot-imm## set-slot## } related-words
HELP: ##single>double-float
HELP: single>double-float##
{ $class-description "Converts a single precision value (32-bit usually) stored in a SIMD register to a double precision one (64-bit usually)." } ;
HELP: ##shuffle-vector-imm
HELP: shuffle-vector-imm##
{ $class-description "Shuffles the vector in a SSE register according to the given shuffle pattern. It is used to extract a given element of the vector."
{ $table
{ { $slot "dst" } { "Destination register to shuffle the vector to." } }
@ -276,7 +276,7 @@ HELP: ##shuffle-vector-imm
}
{ $see-also %shuffle-vector-imm } ;
HELP: ##slot-imm
HELP: slot-imm##
{ $class-description
"Instruction for reading a slot with a given index from an object."
{ $table
@ -287,15 +287,15 @@ HELP: ##slot-imm
}
} { $see-also %slot-imm } ;
HELP: ##spill
HELP: spill##
{ $class-description "Instruction that copies a value from a register to a " { $link spill-slot } "."
{ $table
{ { $slot "rep" } { "Register representation which is necessary when spilling SIMD registers." } }
}
} { $see-also ##reload } ;
} { $see-also reload## } ;
HELP: ##store-memory-imm
{ $class-description "Instruction that copies an 8 byte value from a XMM register to a memory location addressed by a normal register. This instruction is often turned into a cheaper " { $link ##store-memory } " instruction in the " { $link value-numbering } " pass."
HELP: store-memory-imm##
{ $class-description "Instruction that copies an 8 byte value from a XMM register to a memory location addressed by a normal register. This instruction is often turned into a cheaper " { $link store-memory## } " instruction in the " { $link value-numbering } " pass."
{ $table
{ { $slot "base" } { "Vreg that contains the base address." } }
{
@ -308,11 +308,11 @@ HELP: ##store-memory-imm
}
{ $see-also %store-memory-imm } ;
HELP: ##test-branch
HELP: test-branch##
{ $class-description "Instruction inserted by the " { $vocab-link "compiler.cfg.value-numbering" } " compiler pass." }
{ $see-also ##compare-integer-imm-branch } ;
{ $see-also compare-integer-imm-branch## } ;
HELP: ##unbox-any-c-ptr
HELP: unbox-any-c-ptr##
{ $class-description "Instruction that unboxes a pointer in a register so that it can be fed to a C FFI function. For example, if 'src' points to a " { $link byte-array } ", then in 'dst' will be put a pointer to the first byte of that byte array."
{ $table
{ { $slot "dst" } { "Destination register." } }
@ -321,12 +321,12 @@ HELP: ##unbox-any-c-ptr
}
{ $see-also %unbox-any-c-ptr } ;
HELP: ##unbox-long-long
HELP: unbox-long-long##
{ $class-description "Instruction that unboxes a 64-bit integer to two 32-bit registers. Only used on 32 bit architectures." } ;
HELP: ##vector>scalar
HELP: vector>scalar##
{ $class-description
"This instruction is very similar to " { $link ##copy } "."
"This instruction is very similar to " { $link copy## } "."
{ $table
{ { $slot "dst" } { "destination vreg" } }
{ { $slot "src" } { "source vreg" } }
@ -336,7 +336,7 @@ HELP: ##vector>scalar
{ $notes "The two vregs must not necessarily share the same representation." }
{ $see-also %vector>scalar } ;
HELP: ##vm-field
HELP: vm-field##
{ $class-description "Instruction for loading a pointer to a vm field."
{ $table
{ { $slot "dst" } { "Register to load the field into." } }
@ -345,9 +345,9 @@ HELP: ##vm-field
}
{ $see-also %vm-field } ;
HELP: ##write-barrier
HELP: write-barrier##
{ $class-description
"An instruction for inserting a write barrier. This instruction is almost always inserted after a " { $link ##set-slot } " instruction. If the container object is in an older generation than the item inserted, this instruction guarantees that the item will not be garbage collected. It has the following slots:"
"An instruction for inserting a write barrier. This instruction is almost always inserted after a " { $link set-slot## } " instruction. If the container object is in an older generation than the item inserted, this instruction guarantees that the item will not be garbage collected. It has the following slots:"
{ $table
{ { $slot "src" } { "Object to which the writer barrier refers." } }
{ { $slot "slot" } { "Slot index of the object." } }
@ -412,51 +412,51 @@ HELP: gc-map
ARTICLE: "compiler.cfg.instructions" "Basic block instructions"
"The " { $vocab-link "compiler.cfg.instructions" } " vocab contains all instruction classes used for generating CFG:s (Call Flow Graphs)."
$nl
"All instructions are tuples prefixed with '##' and inheriting from the base class " { $link insn } ". Most instructions are coupled with a generic word in " { $vocab-link "cpu.architecture" } " which emits machine code for it. For example, " { $link %copy } " emits code for " { $link ##copy } " instructions."
"All instructions are tuples prefixed with '##' and inheriting from the base class " { $link insn } ". Most instructions are coupled with a generic word in " { $vocab-link "cpu.architecture" } " which emits machine code for it. For example, " { $link %copy } " emits code for " { $link copy## } " instructions."
$nl
"Instruction classes for moving values around:"
{ $subsections
##copy
##parallel-copy
##peek
##reload
##replace
##replace-imm
##spill
copy##
parallel-copy##
peek##
reload##
replace##
replace-imm##
spill##
}
"Control flow:"
{ $subsections
##branch
##call
##jump
##no-tco
##phi
##return
branch##
call##
jump##
no-tco##
phi##
return##
}
"Alien calls and FFI:"
{ $subsections
##alien-assembly
##alien-indirect
##alien-invoke
##box
##box-alien
##box-displaced-alien
##box-long-long
##callback-inputs
##callback-outputs
##unbox
##unbox-alien
##unbox-any-c-ptr
##unbox-long-long
alien-assembly##
alien-indirect##
alien-invoke##
box##
box-alien##
box-displaced-alien##
box-long-long##
callback-inputs##
callback-outputs##
unbox##
unbox-alien##
unbox-any-c-ptr##
unbox-long-long##
alien-call-insn
}
"Allocation and garbage collection:"
{ $subsections
##allot
##call-gc
##check-nursery-branch
##local-allot
##save-context
allot##
call-gc##
check-nursery-branch##
local-allot##
save-context##
allocation-insn
gc-map
gc-map-insn
@ -464,84 +464,84 @@ $nl
}
"Comparison instructions:"
{ $subsections
##compare
##compare-imm
##compare-imm-branch
##compare-integer
##compare-integer-branch
##compare-integer-imm-branch
##test
##test-branch
##test-imm
##test-imm-branch
compare##
compare-imm##
compare-imm-branch##
compare-integer##
compare-integer-branch##
compare-integer-imm-branch##
test##
test-branch##
test-imm##
test-imm-branch##
}
"Constant loading:"
{ $subsections
##load-integer
##load-reference
##load-tagged
load-integer##
load-reference##
load-tagged##
}
"Floating point SIMD instructions:"
{ $subsections
##add-float
##div-float
##mul-float
##sub-float
add-float##
div-float##
mul-float##
sub-float##
}
"Integer arithmetic and bit operations:"
{ $subsections
##add
##add-imm
##and
##and-imm
##fixnum-add
##fixnum-sub
##mul
##mul-imm
##neg
##not
##or
##or-imm
##sar
##sar-imm
##shl
##shl-imm
##shr
##shr-imm
##sub
##sub-imm
##xor
##xor-imm
add##
add-imm##
and##
and-imm##
fixnum-add##
fixnum-sub##
mul##
mul-imm##
neg##
not##
or##
or-imm##
sar##
sar-imm##
shl##
shl-imm##
shr##
shr-imm##
sub##
sub-imm##
xor##
xor-imm##
}
"Slot access:"
{ $subsections
##slot
##slot-imm
##set-slot
##set-slot-imm
##write-barrier
slot##
slot-imm##
set-slot##
set-slot-imm##
write-barrier##
}
"SIMD instructions"
{ $subsections
##add-vector
##add-sub-vector
##bit-count
##compare-float-ordered-branch
##div-vector
##horizontal-add-vector
##horizontal-sub-vector
##load-double
##load-vector
##mul-vector
##shuffle-vector-imm
##single>double-float
##store-memory-imm
##sub-vector
##vector>scalar
add-vector##
add-sub-vector##
bit-count##
compare-float-ordered-branch##
div-vector##
horizontal-add-vector##
horizontal-sub-vector##
load-double##
load-vector##
mul-vector##
shuffle-vector-imm##
single>double-float##
store-memory-imm##
sub-vector##
vector>scalar##
}
"Stack height manipulation:"
{ $subsections
##inc
inc##
} ;
ABOUT: "compiler.cfg.instructions"

400
basis/compiler/cfg/instructions/instructions.factor
View File

File diff suppressed because it is too large Load Diff

4
basis/compiler/cfg/intrinsics/alien/alien-docs.factor
View File

@ -4,9 +4,9 @@ IN: compiler.cfg.intrinsics.alien
HELP: inline-accessor
{ $values
{ "block" basic-block }
{ "#call" #call }
{ "call#" call# }
{ "quot" quotation }
{ "test" quotation }
{ "block'" basic-block }
}
{ $description "Combinator used to simplify writing intrinsic emitting code. If the 'test' quotation yields " { $link t } " when called on the '#call' nodes inputs, then the 'quot' quotation is used to emit intrinsic instructions. Otherwise a primitive call is emitted. " } ;
{ $description "Combinator used to simplify writing intrinsic emitting code. If the 'test' quotation yields " { $link t } " when called on the 'call#' nodes inputs, then the 'quot' quotation is used to emit intrinsic instructions. Otherwise a primitive call is emitted. " } ;

18
basis/compiler/cfg/intrinsics/alien/alien-tests.factor
View File

@ -7,8 +7,8 @@ IN: compiler.cfg.intrinsics.alien.tests
! emit-<displaced-alien>
: call-<displaced-alien> ( -- #call )
T{ #call
: call-<displaced-alien> ( -- call# )
T{ call#
{ word <displaced-alien> }
{ in-d V{ 8583268 8583269 } }
{ out-d { 8583267 } }
@ -41,8 +41,8 @@ IN: compiler.cfg.intrinsics.alien.tests
{
V{
T{ ##call { word <displaced-alien> } }
T{ ##branch }
T{ call## { word <displaced-alien> } }
T{ branch## }
}
} [
<basic-block> dup set-basic-block
@ -53,19 +53,19 @@ IN: compiler.cfg.intrinsics.alien.tests
! emit-alien-cell
{
V{
T{ ##load-integer { dst 3 } { val 0 } }
T{ ##add { dst 4 } { src1 3 } { src2 2 } }
T{ ##load-memory-imm
T{ load-integer## { dst 3 } { val 0 } }
T{ add## { dst 4 } { src1 3 } { src2 2 } }
T{ load-memory-imm##
{ dst 5 }
{ base 4 }
{ offset 0 }
{ rep int-rep }
}
T{ ##box-alien { dst 7 } { src 5 } { temp 6 } }
T{ box-alien## { dst 7 } { src 5 } { temp 6 } }
}
} [
<basic-block>
T{ #call
T{ call#
{ word alien-cell }
{ in-d V{ 10 20 } }
{ out-d { 30 } }

8
basis/compiler/cfg/intrinsics/alien/alien.factor
View File

@ -21,11 +21,11 @@ IN: compiler.cfg.intrinsics.alien
] binary-op
] [ emit-primitive ] if ;
:: inline-accessor ( block #call quot test -- block' )
#call node-input-infos :> infos
:: inline-accessor ( block call# quot test -- block' )
call# node-input-infos :> infos
infos test call
[ infos quot call block ]
[ block #call emit-primitive ] if ; inline
[ block call# emit-primitive ] if ; inline
: inline-load-memory? ( infos -- ? )
[ first class>> c-ptr class<= ]
@ -60,7 +60,7 @@ IN: compiler.cfg.intrinsics.alien
:: (emit-store-memory) ( block node rep c-type prepare-quot test-quot -- block' )
block node
[ prepare-quot call rep c-type ##store-memory-imm, ]
[ prepare-quot call rep c-type store-memory-imm##, ]
[ test-quot call inline-store-memory? ]
inline-accessor ; inline

4
basis/compiler/cfg/intrinsics/allot/allot-docs.factor
View File

@ -5,7 +5,7 @@ IN: compiler.cfg.intrinsics.allot
HELP: emit-<byte-array>
{ $values
{ "block" "current " { $link basic-block } }
{ "#call" node }
{ "call#" node }
{ "block'" basic-block }
}
{ $description "Emits optimized cfg instructions for allocating a " { $link byte-array } "." } ;
@ -13,7 +13,7 @@ HELP: emit-<byte-array>
HELP: emit-<tuple-boa>
{ $values
{ "block" "current " { $link basic-block } }
{ "#call" #call }
{ "call#" call# }
{ "block'" basic-block }
}
{ $description "Emits intrinsic cfg instructions for building and allocating tuples. The intrinsic condition is that the tuple layout given to " { $link <tuple-boa> } " must be a literal." }

22
basis/compiler/cfg/intrinsics/allot/allot.factor
View File

@ -7,13 +7,13 @@ compiler.constants compiler.tree.propagation.info cpu.architecture fry
kernel layouts locals math math.order namespaces sequences ;
IN: compiler.cfg.intrinsics.allot
: ##set-slots, ( regs obj class -- )
'[ _ swap 1 + _ type-number ##set-slot-imm, ] each-index ;
: set-slots##, ( regs obj class -- )
'[ _ swap 1 + _ type-number set-slot-imm##, ] each-index ;
: emit-simple-allot ( node -- )
[ in-d>> length ] [ node-output-infos first class>> ] bi
[ drop ds-loc load-vregs ] [ [ 1 + cells ] dip ^^allot ] [ nip ] 2tri
[ ##set-slots, ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
[ set-slots##, ] [ [ drop ] [ ds-push ] [ drop ] tri* ] 3bi ;
: tuple-slot-regs ( layout -- vregs )
[ second ds-loc load-vregs ] [ ^^load-literal ] bi prefix ;
@ -21,20 +21,20 @@ IN: compiler.cfg.intrinsics.allot
: ^^allot-tuple ( n -- dst )
2 + cells tuple ^^allot ;
: emit-<tuple-boa> ( block #call -- block' )
: emit-<tuple-boa> ( block call# -- block' )
dup node-input-infos last literal>>
dup array? [
nip
ds-drop
[ tuple-slot-regs ] [ second ^^allot-tuple ] bi
[ tuple ##set-slots, ] [ ds-push drop ] 2bi
[ tuple set-slots##, ] [ ds-push drop ] 2bi
] [ drop emit-primitive ] if ;
: store-length ( len reg class -- )
[ [ ^^load-literal ] dip 1 ] dip type-number ##set-slot-imm, ;
[ [ ^^load-literal ] dip 1 ] dip type-number set-slot-imm##, ;
:: store-initial-element ( len reg elt class -- )
len [ [ elt reg ] dip 2 + class type-number ##set-slot-imm, ] each-integer ;
len [ [ elt reg ] dip 2 + class type-number set-slot-imm##, ] each-integer ;
: expand-<array>? ( obj -- ? )
dup integer? [ 0 8 between? ] [ drop f ] if ;
@ -76,12 +76,12 @@ IN: compiler.cfg.intrinsics.allot
0 ^^load-literal :> elt
reg ^^tagged>integer :> reg
len cell align cell /i <iota> [
[ elt reg ] dip cells byte-array-offset + int-rep f ##store-memory-imm,
[ elt reg ] dip cells byte-array-offset + int-rep f store-memory-imm##,
] each ;
:: emit-<byte-array> ( block #call -- block' )
#call node-input-infos first literal>> dup expand-<byte-array>? [
:: emit-<byte-array> ( block call# -- block' )
call# node-input-infos first literal>> dup expand-<byte-array>? [
:> len
len emit-allot-byte-array :> reg
len reg zero-byte-array block
] [ drop block #call emit-primitive ] if ;
] [ drop block call# emit-primitive ] if ;

4
basis/compiler/cfg/intrinsics/fixnum/fixnum-docs.factor
View File

@ -9,7 +9,7 @@ HELP: fixnum*overflow
HELP: emit-fixnum-comparison
{ $values { "cc" "comparison symbol" } }
{ $description "Emits a " { $link ##compare-integer } " instruction to the make sequence." } ;
{ $description "Emits a " { $link compare-integer## } " instruction to the make sequence." } ;
HELP: emit-fixnum-overflow-op
{ $values
@ -25,7 +25,7 @@ HELP: emit-fixnum-shift-general
{ "block" basic-block }
{ "block'" basic-block }
}
{ $description "Emits intrinsic code for shifting a " { $link fixnum } ". For positive shifts, " { $link ##shl } " is used, for negative shifts it is more complicated." } ;
{ $description "Emits intrinsic code for shifting a " { $link fixnum } ". For positive shifts, " { $link shl## } " is used, for negative shifts it is more complicated." } ;
ARTICLE: "compiler.cfg.intrinsics.fixnum" "Generating instructions for fixnum arithmetic"
"Combinators:"

12
basis/compiler/cfg/intrinsics/fixnum/fixnum-tests.factor
View File

@ -7,7 +7,7 @@ IN: compiler.cfg.intrinsics.fixnum.tests
{
V{
T{ ##compare-integer
T{ compare-integer##
{ dst 4 }
{ src1 1 }
{ src2 2 }
@ -21,7 +21,7 @@ IN: compiler.cfg.intrinsics.fixnum.tests
{
V{
T{ ##compare-integer-imm-branch
T{ compare-integer-imm-branch##
{ src1 1 }
{ src2 0 }
{ cc cc> }
@ -37,13 +37,13 @@ IN: compiler.cfg.intrinsics.fixnum.tests
{
V{
T{ ##copy
T{ copy##
{ dst 1 }
{ src 321 }
{ rep any-rep }
}
T{ ##inc { loc d: -1 } }
T{ ##branch }
T{ inc## { loc d: -1 } }
T{ branch## }
}
77
} [
@ -52,7 +52,7 @@ IN: compiler.cfg.intrinsics.fixnum.tests
] cfg-unit-test
{
V{ T{ ##call { word 2drop } } T{ ##branch } }
V{ T{ call## { word 2drop } } T{ branch## } }
107
} [
\ 2drop V{ } 107 insns>block emit-overflow-case

4
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
View File

@ -25,12 +25,12 @@ IN: compiler.cfg.intrinsics.fixnum
] binary-op ;
: emit-fixnum-shift-general ( block -- block' )
ds-peek 0 cc> ##compare-integer-imm-branch, dup
ds-peek 0 cc> compare-integer-imm-branch##, dup
[ [ emit-fixnum-left-shift ] with-branch ]
[ [ emit-fixnum-right-shift ] with-branch ] bi 2array
emit-conditional ;
: emit-fixnum-shift-fast ( block #call -- block' )
: emit-fixnum-shift-fast ( block call# -- block' )
node-input-infos second interval>> {
{ [ dup 0 [a,inf] interval-subset? ] [ drop emit-fixnum-left-shift ] }
{ [ dup 0 [-inf,a] interval-subset? ] [ drop emit-fixnum-right-shift ] }

4
basis/compiler/cfg/intrinsics/misc/misc.factor
View File

@ -24,7 +24,7 @@ IN: compiler.cfg.intrinsics.misc
: emit-set-special-object ( block node -- block' )
dup node-input-infos second literal>> [
ds-drop
[ ds-pop ] dip vm-special-object-offset ##set-vm-field,
[ ds-pop ] dip vm-special-object-offset set-vm-field##,
] [ emit-primitive ] ?if ;
: context-object-offset ( n -- n )
@ -50,4 +50,4 @@ IN: compiler.cfg.intrinsics.misc
[ 2drop emit-primitive ] if ;
: emit-cleanup-allot ( block node -- block' )
drop [ drop ##no-tco, ] emit-trivial-block ;
drop [ drop no-tco##, ] emit-trivial-block ;

126
basis/compiler/cfg/intrinsics/simd/backend/backend.factor
View File

@ -10,79 +10,79 @@ IN: compiler.cfg.intrinsics.simd.backend
! Selection of implementation based on available CPU instructions
GENERIC: insn-available? ( ## -- reps )
GENERIC: insn-available? ( object -- reps )
M: object insn-available? drop t ;
M: ##zero-vector insn-available? rep>> %zero-vector-reps member? ;
M: ##fill-vector insn-available? rep>> %fill-vector-reps member? ;
M: ##gather-vector-2 insn-available? rep>> %gather-vector-2-reps member? ;
M: ##gather-vector-4 insn-available? rep>> %gather-vector-4-reps member? ;
M: ##gather-int-vector-2 insn-available? rep>> %gather-int-vector-2-reps member? ;
M: ##gather-int-vector-4 insn-available? rep>> %gather-int-vector-4-reps member? ;
M: ##select-vector insn-available? rep>> %select-vector-reps member? ;
M: ##store-memory-imm insn-available? rep>> %alien-vector-reps member? ;
M: ##shuffle-vector insn-available? rep>> %shuffle-vector-reps member? ;
M: ##shuffle-vector-imm insn-available? rep>> %shuffle-vector-imm-reps member? ;
M: ##shuffle-vector-halves-imm insn-available? rep>> %shuffle-vector-halves-imm-reps member? ;
M: ##merge-vector-head insn-available? rep>> %merge-vector-reps member? ;
M: ##merge-vector-tail insn-available? rep>> %merge-vector-reps member? ;
M: ##float-pack-vector insn-available? rep>> %float-pack-vector-reps member? ;
M: ##signed-pack-vector insn-available? rep>> %signed-pack-vector-reps member? ;
M: ##unsigned-pack-vector insn-available? rep>> %unsigned-pack-vector-reps member? ;
M: ##unpack-vector-head insn-available? rep>> %unpack-vector-head-reps member? ;
M: ##unpack-vector-tail insn-available? rep>> %unpack-vector-tail-reps member? ;
M: ##tail>head-vector insn-available? rep>> %unpack-vector-head-reps member? ;
M: ##integer>float-vector insn-available? rep>> %integer>float-vector-reps member? ;
M: ##float>integer-vector insn-available? rep>> %float>integer-vector-reps member? ;
M: ##compare-vector insn-available? [ rep>> ] [ cc>> ] bi %compare-vector-reps member? ;
M: ##move-vector-mask insn-available? rep>> %move-vector-mask-reps member? ;
M: ##test-vector insn-available? rep>> %test-vector-reps member? ;
M: ##add-vector insn-available? rep>> %add-vector-reps member? ;
M: ##saturated-add-vector insn-available? rep>> %saturated-add-vector-reps member? ;
M: ##add-sub-vector insn-available? rep>> %add-sub-vector-reps member? ;
M: ##sub-vector insn-available? rep>> %sub-vector-reps member? ;
M: ##saturated-sub-vector insn-available? rep>> %saturated-sub-vector-reps member? ;
M: ##mul-vector insn-available? rep>> %mul-vector-reps member? ;
M: ##mul-high-vector insn-available? rep>> %mul-high-vector-reps member? ;
M: ##mul-horizontal-add-vector insn-available? rep>> %mul-horizontal-add-vector-reps member? ;
M: ##saturated-mul-vector insn-available? rep>> %saturated-mul-vector-reps member? ;
M: ##div-vector insn-available? rep>> %div-vector-reps member? ;
M: ##min-vector insn-available? rep>> %min-vector-reps member? ;
M: ##max-vector insn-available? rep>> %max-vector-reps member? ;
M: ##avg-vector insn-available? rep>> %avg-vector-reps member? ;
M: ##dot-vector insn-available? rep>> %dot-vector-reps member? ;
M: ##sad-vector insn-available? rep>> %sad-vector-reps member? ;
M: ##sqrt-vector insn-available? rep>> %sqrt-vector-reps member? ;
M: ##horizontal-add-vector insn-available? rep>> %horizontal-add-vector-reps member? ;
M: ##horizontal-sub-vector insn-available? rep>> %horizontal-sub-vector-reps member? ;
M: ##abs-vector insn-available? rep>> %abs-vector-reps member? ;
M: ##and-vector insn-available? rep>> %and-vector-reps member? ;
M: ##andn-vector insn-available? rep>> %andn-vector-reps member? ;
M: ##or-vector insn-available? rep>> %or-vector-reps member? ;
M: ##xor-vector insn-available? rep>> %xor-vector-reps member? ;
M: ##not-vector insn-available? rep>> %not-vector-reps member? ;
M: ##shl-vector insn-available? rep>> %shl-vector-reps member? ;
M: ##shr-vector insn-available? rep>> %shr-vector-reps member? ;
M: ##shl-vector-imm insn-available? rep>> %shl-vector-imm-reps member? ;
M: ##shr-vector-imm insn-available? rep>> %shr-vector-imm-reps member? ;
M: ##horizontal-shl-vector-imm insn-available? rep>> %horizontal-shl-vector-imm-reps member? ;
M: ##horizontal-shr-vector-imm insn-available? rep>> %horizontal-shr-vector-imm-reps member? ;
M: zero-vector## insn-available? rep>> %zero-vector-reps member? ;
M: fill-vector## insn-available? rep>> %fill-vector-reps member? ;
M: gather-vector-2## insn-available? rep>> %gather-vector-2-reps member? ;
M: gather-vector-4## insn-available? rep>> %gather-vector-4-reps member? ;
M: gather-int-vector-2## insn-available? rep>> %gather-int-vector-2-reps member? ;
M: gather-int-vector-4## insn-available? rep>> %gather-int-vector-4-reps member? ;
M: select-vector## insn-available? rep>> %select-vector-reps member? ;
M: store-memory-imm## insn-available? rep>> %alien-vector-reps member? ;
M: shuffle-vector## insn-available? rep>> %shuffle-vector-reps member? ;
M: shuffle-vector-imm## insn-available? rep>> %shuffle-vector-imm-reps member? ;
M: shuffle-vector-halves-imm## insn-available? rep>> %shuffle-vector-halves-imm-reps member? ;
M: merge-vector-head## insn-available? rep>> %merge-vector-reps member? ;
M: merge-vector-tail## insn-available? rep>> %merge-vector-reps member? ;
M: float-pack-vector## insn-available? rep>> %float-pack-vector-reps member? ;
M: signed-pack-vector## insn-available? rep>> %signed-pack-vector-reps member? ;
M: unsigned-pack-vector## insn-available? rep>> %unsigned-pack-vector-reps member? ;
M: unpack-vector-head## insn-available? rep>> %unpack-vector-head-reps member? ;
M: unpack-vector-tail## insn-available? rep>> %unpack-vector-tail-reps member? ;
M: tail>head-vector## insn-available? rep>> %unpack-vector-head-reps member? ;
M: integer>float-vector## insn-available? rep>> %integer>float-vector-reps member? ;
M: float>integer-vector## insn-available? rep>> %float>integer-vector-reps member? ;
M: compare-vector## insn-available? [ rep>> ] [ cc>> ] bi %compare-vector-reps member? ;
M: move-vector-mask## insn-available? rep>> %move-vector-mask-reps member? ;
M: test-vector## insn-available? rep>> %test-vector-reps member? ;
M: add-vector## insn-available? rep>> %add-vector-reps member? ;
M: saturated-add-vector## insn-available? rep>> %saturated-add-vector-reps member? ;
M: add-sub-vector## insn-available? rep>> %add-sub-vector-reps member? ;
M: sub-vector## insn-available? rep>> %sub-vector-reps member? ;
M: saturated-sub-vector## insn-available? rep>> %saturated-sub-vector-reps member? ;
M: mul-vector## insn-available? rep>> %mul-vector-reps member? ;
M: mul-high-vector## insn-available? rep>> %mul-high-vector-reps member? ;
M: mul-horizontal-add-vector## insn-available? rep>> %mul-horizontal-add-vector-reps member? ;
M: saturated-mul-vector## insn-available? rep>> %saturated-mul-vector-reps member? ;
M: div-vector## insn-available? rep>> %div-vector-reps member? ;
M: min-vector## insn-available? rep>> %min-vector-reps member? ;
M: max-vector## insn-available? rep>> %max-vector-reps member? ;
M: avg-vector## insn-available? rep>> %avg-vector-reps member? ;
M: dot-vector## insn-available? rep>> %dot-vector-reps member? ;
M: sad-vector## insn-available? rep>> %sad-vector-reps member? ;
M: sqrt-vector## insn-available? rep>> %sqrt-vector-reps member? ;
M: horizontal-add-vector## insn-available? rep>> %horizontal-add-vector-reps member? ;
M: horizontal-sub-vector## insn-available? rep>> %horizontal-sub-vector-reps member? ;
M: abs-vector## insn-available? rep>> %abs-vector-reps member? ;
M: and-vector## insn-available? rep>> %and-vector-reps member? ;
M: andn-vector## insn-available? rep>> %andn-vector-reps member? ;
M: or-vector## insn-available? rep>> %or-vector-reps member? ;
M: xor-vector## insn-available? rep>> %xor-vector-reps member? ;
M: not-vector## insn-available? rep>> %not-vector-reps member? ;
M: shl-vector## insn-available? rep>> %shl-vector-reps member? ;
M: shr-vector## insn-available? rep>> %shr-vector-reps member? ;
M: shl-vector-imm## insn-available? rep>> %shl-vector-imm-reps member? ;
M: shr-vector-imm## insn-available? rep>> %shr-vector-imm-reps member? ;
M: horizontal-shl-vector-imm## insn-available? rep>> %horizontal-shl-vector-imm-reps member? ;
M: horizontal-shr-vector-imm## insn-available? rep>> %horizontal-shr-vector-imm-reps member? ;
: [vector-op-checked] ( #dup quot -- quot )
: [vector-op-checked] ( dup# quot -- quot )
'[ _ ndup _ { } make dup [ insn-available? ] all? ] ;
GENERIC#: >vector-op-cond 2 ( quot #pick #dup -- quotpair )
M:: callable >vector-op-cond ( quot #pick #dup -- quotpair )
#dup quot [vector-op-checked] '[ 2drop @ ]
#dup '[ % _ nnip ]
GENERIC#: >vector-op-cond 2 ( quot pick# dup# -- quotpair )
M:: callable >vector-op-cond ( quot pick# dup# -- quotpair )
dup# quot [vector-op-checked] '[ 2drop @ ]
dup# '[ % _ nnip ]
2array ;
M:: pair >vector-op-cond ( pair #pick #dup -- quotpair )
M:: pair >vector-op-cond ( pair pick# dup# -- quotpair )
pair first2 :> ( class quot )
#pick class #dup quot [vector-op-checked]
pick# class dup# quot [vector-op-checked]
'[ 2drop _ npick _ instance? _ [ f f f ] if ]
#dup '[ % _ nnip ]
dup# '[ % _ nnip ]
2array ;
MACRO: v-vector-op ( trials -- quot )

2
basis/compiler/cfg/intrinsics/simd/simd-docs.factor
View File

@ -5,4 +5,4 @@ IN: compiler.cfg.intrinsics.simd
HELP: emit-simd-v+
{ $values { "node" node } }
{ $description "Emits instructions for SIMD vector addition." }
{ $see-also ##add-vector v+ } ;
{ $see-also add-vector## v+ } ;

182
basis/compiler/cfg/intrinsics/simd/simd-tests.factor
View File

@ -9,7 +9,7 @@ namespaces sequences system tools.test words ;
IN: compiler.cfg.intrinsics.simd.tests
:: test-node ( rep -- node )
T{ #call
T{ call#
{ in-d { 1 2 3 4 } }
{ out-d { 5 } }
{ info H{
@ -23,7 +23,7 @@ IN: compiler.cfg.intrinsics.simd.tests
:: test-node-literal ( lit rep -- node )
lit class-of :> lit-class
T{ #call
T{ call#
{ in-d { 1 2 3 4 } }
{ out-d { 5 } }
{ info H{
@ -36,7 +36,7 @@ IN: compiler.cfg.intrinsics.simd.tests
} ;
: test-node-nonliteral-rep ( -- node )
T{ #call
T{ call#
{ in-d { 1 2 3 4 } }
{ out-d { 5 } }
{ info H{
@ -114,31 +114,31 @@ M: simple-ops-cpu %gather-vector-4-reps { int-4-rep uint-4-rep float-4-rep } ;
M: simple-ops-cpu %alien-vector-reps all-reps ;
! v+
{ { ##add-vector } }
{ { add-vector## } }
[ simple-ops-cpu float-4-rep [ emit-simd-v+ ] test-emit ]
unit-test
! v-
{ { ##sub-vector } }
{ { sub-vector## } }
[ simple-ops-cpu float-4-rep [ emit-simd-v- ] test-emit ]
unit-test
! vneg
{ { ##load-reference ##sub-vector } }
{ { load-reference## sub-vector## } }
[ simple-ops-cpu float-4-rep [ emit-simd-vneg ] test-emit ]
unit-test
{ { ##zero-vector ##sub-vector } }
{ { zero-vector## sub-vector## } }
[ simple-ops-cpu int-4-rep [ emit-simd-vneg ] test-emit ]
unit-test
! v*
{ { ##mul-vector } }
{ { mul-vector## } }
[ simple-ops-cpu float-4-rep [ emit-simd-v* ] test-emit ]
unit-test
! v/
{ { ##div-vector } }
{ { div-vector## } }
[ simple-ops-cpu float-4-rep [ emit-simd-v/ ] test-emit ]
unit-test
@ -146,15 +146,15 @@ TUPLE: addsub-cpu < simple-ops-cpu ;
M: addsub-cpu %add-sub-vector-reps { int-4-rep float-4-rep } ;
! v+-
{ { ##add-sub-vector } }
{ { add-sub-vector## } }
[ addsub-cpu float-4-rep [ emit-simd-v+- ] test-emit ]
unit-test
{ { ##load-reference ##xor-vector ##add-vector } }
{ { load-reference## xor-vector## add-vector## } }
[ simple-ops-cpu float-4-rep [ emit-simd-v+- ] test-emit ]
unit-test
{ { ##load-reference ##xor-vector ##sub-vector ##add-vector } }
{ { load-reference## xor-vector## sub-vector## add-vector## } }
[ simple-ops-cpu int-4-rep [ emit-simd-v+- ] test-emit ]
unit-test
@ -164,41 +164,41 @@ M: saturating-cpu %saturated-sub-vector-reps { int-4-rep } ;
M: saturating-cpu %saturated-mul-vector-reps { int-4-rep } ;
! vs+
{ { ##add-vector } }
{ { add-vector## } }
[ simple-ops-cpu float-4-rep [ emit-simd-vs+ ] test-emit ]
unit-test
{ { ##add-vector } }
{ { add-vector## } }
[ saturating-cpu float-4-rep [ emit-simd-vs+ ] test-emit ]
unit-test
{ { ##saturated-add-vector } }
{ { saturated-add-vector## } }
[ saturating-cpu int-4-rep [ emit-simd-vs+ ] test-emit ]
unit-test
! vs-
{ { ##sub-vector } }
{ { sub-vector## } }
[ simple-ops-cpu float-4-rep [ emit-simd-vs- ] test-emit ]
unit-test
{ { ##sub-vector } }
{ { sub-vector## } }
[ saturating-cpu float-4-rep [ emit-simd-vs- ] test-emit ]
unit-test
{ { ##saturated-sub-vector } }
{ { saturated-sub-vector## } }
[ saturating-cpu int-4-rep [ emit-simd-vs- ] test-emit ]
unit-test
! vs*
{ { ##mul-vector } }
{ { mul-vector## } }
[ simple-ops-cpu float-4-rep [ emit-simd-vs* ] test-emit ]
unit-test
{ { ##mul-vector } }
{ { mul-vector## } }
[ saturating-cpu float-4-rep [ emit-simd-vs* ] test-emit ]
unit-test
{ { ##saturated-mul-vector } }
{ { saturated-mul-vector## } }
[ saturating-cpu int-4-rep [ emit-simd-vs* ] test-emit ]
unit-test
@ -213,20 +213,20 @@ M: compare-cpu %compare-vector-reps drop signed-reps ;
M: compare-cpu %compare-vector-ccs nip f 2array 1array f ;
! vmin
{ { ##min-vector } }
{ { min-vector## } }
[ minmax-cpu float-4-rep [ emit-simd-vmin ] test-emit ]
unit-test
{ { ##compare-vector ##and-vector ##andn-vector ##or-vector } }
{ { compare-vector## and-vector## andn-vector## or-vector## } }
[ compare-cpu float-4-rep [ emit-simd-vmin ] test-emit ]
unit-test
! vmax
{ { ##max-vector } }
{ { max-vector## } }
[ minmax-cpu float-4-rep [ emit-simd-vmax ] test-emit ]
unit-test
{ { ##compare-vector ##and-vector ##andn-vector ##or-vector } }
{ { compare-vector## and-vector## andn-vector## or-vector## } }
[ compare-cpu float-4-rep [ emit-simd-vmax ] test-emit ]
unit-test
@ -239,49 +239,49 @@ M: horizontal-cpu %unpack-vector-head-reps signed-reps ;
M: horizontal-cpu %unpack-vector-tail-reps signed-reps ;
! v.
{ { ##dot-vector } }
{ { dot-vector## } }
[ dot-cpu float-4-rep [ emit-simd-v. ] test-emit ]
unit-test
{ { ##mul-vector ##horizontal-add-vector ##horizontal-add-vector ##vector>scalar } }
{ { mul-vector## horizontal-add-vector## horizontal-add-vector## vector>scalar## } }
[ horizontal-cpu float-4-rep [ emit-simd-v. ] test-emit ]
unit-test
{ {
##mul-vector
##merge-vector-head ##merge-vector-tail ##add-vector
##merge-vector-head ##merge-vector-tail ##add-vector
##vector>scalar
mul-vector##
merge-vector-head## merge-vector-tail## add-vector##
merge-vector-head## merge-vector-tail## add-vector##
vector>scalar##
} }
[ simple-ops-cpu float-4-rep [ emit-simd-v. ] test-emit ]
unit-test
! vsqrt
{ { ##sqrt-vector } }
{ { sqrt-vector## } }
[ simple-ops-cpu float-4-rep [ emit-simd-vsqrt ] test-emit ]
unit-test
! sum
{ { ##horizontal-add-vector ##vector>scalar } }
{ { horizontal-add-vector## vector>scalar## } }
[ horizontal-cpu double-2-rep [ emit-simd-sum ] test-emit ]
unit-test
{ { ##horizontal-add-vector ##horizontal-add-vector ##vector>scalar } }
{ { horizontal-add-vector## horizontal-add-vector## vector>scalar## } }
[ horizontal-cpu float-4-rep [ emit-simd-sum ] test-emit ]
unit-test
{ {
##unpack-vector-head ##unpack-vector-tail ##add-vector
##horizontal-add-vector ##horizontal-add-vector
##vector>scalar
unpack-vector-head## unpack-vector-tail## add-vector##
horizontal-add-vector## horizontal-add-vector##
vector>scalar##
} }
[ horizontal-cpu short-8-rep [ emit-simd-sum ] test-emit ]
unit-test
{ {
##unpack-vector-head ##unpack-vector-tail ##add-vector
##horizontal-add-vector ##horizontal-add-vector ##horizontal-add-vector
##vector>scalar
unpack-vector-head## unpack-vector-tail## add-vector##
horizontal-add-vector## horizontal-add-vector## horizontal-add-vector##
vector>scalar##
} }
[ horizontal-cpu char-16-rep [ emit-simd-sum ] test-emit ]
unit-test
@ -294,35 +294,35 @@ M: abs-cpu %abs-vector-reps signed-reps ;
[ simple-ops-cpu uint-4-rep [ emit-simd-vabs ] test-emit ]
unit-test
{ { ##abs-vector } }
{ { abs-vector## } }
[ abs-cpu float-4-rep [ emit-simd-vabs ] test-emit ]
unit-test
{ { ##load-reference ##andn-vector } }
{ { load-reference## andn-vector## } }
[ simple-ops-cpu float-4-rep [ emit-simd-vabs ] test-emit ]
unit-test
{ { ##zero-vector ##sub-vector ##compare-vector ##and-vector ##andn-vector ##or-vector } }
{ { zero-vector## sub-vector## compare-vector## and-vector## andn-vector## or-vector## } }
[ compare-cpu int-4-rep [ emit-simd-vabs ] test-emit ]
unit-test
! vand
{ { ##and-vector } }
{ { and-vector## } }
[ simple-ops-cpu float-4-rep [ emit-simd-vand ] test-emit ]
unit-test
! vandn
{ { ##andn-vector } }
{ { andn-vector## } }
[ simple-ops-cpu float-4-rep [ emit-simd-vandn ] test-emit ]
unit-test
! vor
{ { ##or-vector } }
{ { or-vector## } }
[ simple-ops-cpu float-4-rep [ emit-simd-vor ] test-emit ]
unit-test
! vxor
{ { ##xor-vector } }
{ { xor-vector## } }
[ simple-ops-cpu float-4-rep [ emit-simd-vxor ] test-emit ]
unit-test
@ -330,11 +330,11 @@ TUPLE: not-cpu < simple-ops-cpu ;
M: not-cpu %not-vector-reps signed-reps ;
! vnot
{ { ##not-vector } }
{ { not-vector## } }
[ not-cpu float-4-rep [ emit-simd-vnot ] test-emit ]
unit-test
{ { ##fill-vector ##xor-vector } }
{ { fill-vector## xor-vector## } }
[ simple-ops-cpu float-4-rep [ emit-simd-vnot ] test-emit ]
unit-test
@ -351,30 +351,30 @@ M: horizontal-shift-cpu %horizontal-shl-vector-imm-reps signed-reps ;
M: horizontal-shift-cpu %horizontal-shr-vector-imm-reps signed-reps ;
! vlshift
{ { ##shl-vector-imm } }
{ { shl-vector-imm## } }
[ shift-imm-cpu 2 int-4-rep [ emit-simd-vlshift ] test-emit-literal ]
unit-test
{ { ##shl-vector } }
{ { shl-vector## } }
[ shift-cpu int-4-rep [ emit-simd-vlshift ] test-emit ]
unit-test
! vrshift
{ { ##shr-vector-imm } }
{ { shr-vector-imm## } }
[ shift-imm-cpu 2 int-4-rep [ emit-simd-vrshift ] test-emit-literal ]
unit-test
{ { ##shr-vector } }
{ { shr-vector## } }
[ shift-cpu int-4-rep [ emit-simd-vrshift ] test-emit ]
unit-test
! hlshift
{ { ##horizontal-shl-vector-imm } }
{ { horizontal-shl-vector-imm## } }
[ horizontal-shift-cpu 2 int-4-rep [ emit-simd-hlshift ] test-emit-literal ]
unit-test
! hrshift
{ { ##horizontal-shr-vector-imm } }
{ { horizontal-shr-vector-imm## } }
[ horizontal-shift-cpu 2 int-4-rep [ emit-simd-hrshift ] test-emit-literal ]
unit-test
@ -385,44 +385,44 @@ TUPLE: shuffle-cpu < simple-ops-cpu ;
M: shuffle-cpu %shuffle-vector-reps signed-reps ;
! vshuffle-elements
{ { ##load-reference ##shuffle-vector } }
{ { load-reference## shuffle-vector## } }
[ shuffle-cpu { 0 1 2 3 } int-4-rep [ emit-simd-vshuffle-elements ] test-emit-literal ]
unit-test
{ { ##shuffle-vector-imm } }
{ { shuffle-vector-imm## } }
[ shuffle-imm-cpu { 0 1 2 3 } int-4-rep [ emit-simd-vshuffle-elements ] test-emit-literal ]
unit-test
! vshuffle-bytes
{ { ##shuffle-vector } }
{ { shuffle-vector## } }
[ shuffle-cpu int-4-rep [ emit-simd-vshuffle-bytes ] test-emit ]
unit-test
! vmerge-head
{ { ##merge-vector-head } }
{ { merge-vector-head## } }
[ simple-ops-cpu float-4-rep [ emit-simd-vmerge-head ] test-emit ]
unit-test
! vmerge-tail
{ { ##merge-vector-tail } }
{ { merge-vector-tail## } }
[ simple-ops-cpu float-4-rep [ emit-simd-vmerge-tail ] test-emit ]
unit-test
! v<= etc.
{ { ##compare-vector } }
{ { compare-vector## } }
[ compare-cpu int-4-rep [ emit-simd-v<= ] test-emit ]
unit-test
{ { ##min-vector ##compare-vector } }
{ { min-vector## compare-vector## } }
[ minmax-cpu int-4-rep [ emit-simd-v<= ] test-emit ]
unit-test
{ { ##load-reference ##xor-vector ##xor-vector ##compare-vector } }
{ { load-reference## xor-vector## xor-vector## compare-vector## } }
[ compare-cpu uint-4-rep [ emit-simd-v<= ] test-emit ]
unit-test
! vany? etc.
{ { ##test-vector } }
{ { test-vector## } }
[ simple-ops-cpu int-4-rep [ emit-simd-vany? ] test-emit ]
unit-test
@ -435,7 +435,7 @@ M: convert-cpu %float>integer-vector-reps { float-4-rep } ;
[ convert-cpu float-4-rep [ emit-simd-v>float ] test-emit ]
unit-test
{ { ##integer>float-vector } }
{ { integer>float-vector## } }
[ convert-cpu int-4-rep [ emit-simd-v>float ] test-emit ]
unit-test
@ -444,17 +444,17 @@ unit-test
[ convert-cpu int-4-rep [ emit-simd-v>integer ] test-emit ]
unit-test
{ { ##float>integer-vector } }
{ { float>integer-vector## } }
[ convert-cpu float-4-rep [ emit-simd-v>integer ] test-emit ]
unit-test
! vpack-signed
{ { ##signed-pack-vector } }
{ { signed-pack-vector## } }
[ simple-ops-cpu int-4-rep [ emit-simd-vpack-signed ] test-emit ]
unit-test
! vpack-unsigned
{ { ##unsigned-pack-vector } }
{ { unsigned-pack-vector## } }
[ simple-ops-cpu int-4-rep [ emit-simd-vpack-unsigned ] test-emit ]
unit-test
@ -464,71 +464,71 @@ TUPLE: unpack-cpu < unpack-head-cpu ;
M: unpack-cpu %unpack-vector-tail-reps all-reps ;
! vunpack-head
{ { ##unpack-vector-head } }
{ { unpack-vector-head## } }
[ unpack-head-cpu int-4-rep [ emit-simd-vunpack-head ] test-emit ]
unit-test
{ { ##zero-vector ##merge-vector-head } }
{ { zero-vector## merge-vector-head## } }
[ simple-ops-cpu uint-4-rep [ emit-simd-vunpack-head ] test-emit ]
unit-test
{ { ##merge-vector-head ##shr-vector-imm } }
{ { merge-vector-head## shr-vector-imm## } }
[ shift-imm-cpu int-4-rep [ emit-simd-vunpack-head ] test-emit ]
unit-test
{ { ##zero-vector ##compare-vector ##merge-vector-head } }
{ { zero-vector## compare-vector## merge-vector-head## } }
[ compare-cpu int-4-rep [ emit-simd-vunpack-head ] test-emit ]
unit-test
! vunpack-tail
{ { ##unpack-vector-tail } }
{ { unpack-vector-tail## } }
[ unpack-cpu int-4-rep [ emit-simd-vunpack-tail ] test-emit ]
unit-test
{ { ##tail>head-vector ##unpack-vector-head } }
{ { tail>head-vector## unpack-vector-head## } }
[ unpack-head-cpu int-4-rep [ emit-simd-vunpack-tail ] test-emit ]
unit-test
{ { ##zero-vector ##merge-vector-tail } }
{ { zero-vector## merge-vector-tail## } }
[ simple-ops-cpu uint-4-rep [ emit-simd-vunpack-tail ] test-emit ]
unit-test
{ { ##merge-vector-tail ##shr-vector-imm } }
{ { merge-vector-tail## shr-vector-imm## } }
[ shift-imm-cpu int-4-rep [ emit-simd-vunpack-tail ] test-emit ]
unit-test
{ { ##zero-vector ##compare-vector ##merge-vector-tail } }
{ { zero-vector## compare-vector## merge-vector-tail## } }
[ compare-cpu int-4-rep [ emit-simd-vunpack-tail ] test-emit ]
unit-test
! with
{ { ##scalar>vector ##shuffle-vector-imm } }
{ { scalar>vector## shuffle-vector-imm## } }
[ shuffle-imm-cpu float-4-rep [ emit-simd-with ] test-emit ]
unit-test
! gather-2
{ { ##gather-vector-2 } }
{ { gather-vector-2## } }
[ simple-ops-cpu double-2-rep [ emit-simd-gather-2 ] test-emit ]
unit-test
! gather-4
{ { ##gather-vector-4 } }
{ { gather-vector-4## } }
[ simple-ops-cpu float-4-rep [ emit-simd-gather-4 ] test-emit ]
unit-test
! select
{ { ##shuffle-vector-imm ##vector>scalar } }
{ { shuffle-vector-imm## vector>scalar## } }
[ shuffle-imm-cpu 1 float-4-rep [ emit-simd-select ] test-emit-literal ]
unit-test
! ^load-neg-zero-vector
{
V{
T{ ##load-reference
T{ load-reference##
{ dst 1 }
{ obj B{ 0 0 0 128 0 0 0 128 0 0 0 128 0 0 0 128 } }
}
T{ ##load-reference
T{ load-reference##
{ dst 2 }
{ obj B{ 0 0 0 0 0 0 0 128 0 0 0 0 0 0 0 128 } }
}
@ -542,33 +542,33 @@ unit-test
! ^load-add-sub-vector
{
V{
T{ ##load-reference
T{ load-reference##
{ dst 1 }
{ obj B{ 0 0 0 128 0 0 0 0 0 0 0 128 0 0 0 0 } }
}
T{ ##load-reference
T{ load-reference##
{ dst 2 }
{ obj B{ 0 0 0 0 0 0 0 128 0 0 0 0 0 0 0 0 } }
}
T{ ##load-reference
T{ load-reference##
{ dst 3 }
{ obj
B{ 255 0 255 0 255 0 255 0 255 0 255 0 255 0 255 0 }
}
}
T{ ##load-reference
T{ load-reference##
{ dst 4 }
{ obj
B{ 255 255 0 0 255 255 0 0 255 255 0 0 255 255 0 0 }
}
}
T{ ##load-reference
T{ load-reference##
{ dst 5 }
{ obj
B{ 255 255 255 255 0 0 0 0 255 255 255 255 0 0 0 0 }
}
}
T{ ##load-reference
T{ load-reference##
{ dst 6 }
{ obj
B{ 255 255 255 255 255 255 255 255 0 0 0 0 0 0 0 0 }
@ -591,11 +591,11 @@ unit-test
! ^load-half-vector
{
V{
T{ ##load-reference
T{ load-reference##
{ dst 1 }
{ obj B{ 0 0 0 63 0 0 0 63 0 0 0 63 0 0 0 63 } }
}
T{ ##load-reference
T{ load-reference##
{ dst 2 }
{ obj B{ 0 0 0 0 0 0 224 63 0 0 0 0 0 0 224 63 } }
}

2
basis/compiler/cfg/intrinsics/simd/simd.factor
View File

@ -646,7 +646,7 @@ PREDICATE: fixnum-vector-rep < int-vector-rep
dup [
'[
ds-drop prepare-store-memory
_ f ##store-memory-imm,
_ f store-memory-imm##,
]
[ byte-array inline-store-memory? ] inline-accessor
] with { [ %alien-vector-reps member? ] } if-literals-match ;

6
basis/compiler/cfg/intrinsics/slots/slots-docs.factor
View File

@ -17,7 +17,7 @@ HELP: class-tag
HELP: immediate-slot-offset?
{ $values { "object" object } { "?" boolean } }
{ $description
{ $link t } " if the object is a " { $link fixnum } " that is small enough to fit into a machine register. It is used to determine whether immediate versions of the instructions " { $link ##set-slot } " and " { $link ##set-slot-imm } " can be emitted." }
{ $link t } " if the object is a " { $link fixnum } " that is small enough to fit into a machine register. It is used to determine whether immediate versions of the instructions " { $link set-slot## } " and " { $link set-slot-imm## } " can be emitted." }
{ $examples
{ $example
"USING: compiler.cfg.intrinsics.slots compiler.tree.propagation.info prettyprint ;"
@ -28,7 +28,7 @@ HELP: immediate-slot-offset?
HELP: node>set-slot-data
{ $values
{ "#call" #call }
{ "call#" call# }
{ "write-barrier?" "whether a write barrier is needed, it always is unless the item to set is an " { $link immediate } }
{ "tag" { $maybe number } }
{ "literal" "a literal" }
@ -41,7 +41,7 @@ HELP: value-tag
HELP: emit-set-slot
{ $values
{ "block" basic-block }
{ "#call" #call }
{ "call#" call# }
{ "block'" basic-block }
}
{ $description "Emits intrinsic code for a " { $link set-slot } " call." } ;

16
basis/compiler/cfg/intrinsics/slots/slots-tests.factor
View File

@ -5,7 +5,7 @@ make math math.intervals sequences slots.private tools.test ;
IN: compiler.cfg.intrinsics.slots.tests
: call-node-1 ( -- node )
T{ #call
T{ call#
{ word set-slot }
{ in-d V{ 9133848 9133849 9133850 } }
{ out-d { } }
@ -37,7 +37,7 @@ IN: compiler.cfg.intrinsics.slots.tests
} ;
: call-node-2 ( -- node )
T{ #call
T{ call#
{ word set-slot }
{ in-d V{ 1 2 3 } }
{ out-d { } }
@ -69,7 +69,7 @@ IN: compiler.cfg.intrinsics.slots.tests
} ;
: call-node-3 ( -- node )
T{ #call
T{ call#
{ word set-slot }
{ in-d V{ 1 2 3 } }
{ out-d { } }
@ -109,7 +109,7 @@ IN: compiler.cfg.intrinsics.slots.tests
! emit-set-slot
{
V{ T{ ##call { word set-slot } } T{ ##branch } }
V{ T{ call## { word set-slot } } T{ branch## } }
} [
<basic-block> dup set-basic-block
call-node-1 [ emit-set-slot ] V{ } make drop
@ -118,14 +118,14 @@ IN: compiler.cfg.intrinsics.slots.tests
{
V{
T{ ##set-slot
T{ set-slot##
{ src 1 }
{ obj 2 }
{ slot 3 }
{ scale $[ cell log2 ] }
{ tag 2 }
}
T{ ##write-barrier
T{ write-barrier##
{ src 2 }
{ slot 3 }
{ scale $[ cell log2 ] }
@ -140,8 +140,8 @@ IN: compiler.cfg.intrinsics.slots.tests
{
V{
T{ ##set-slot-imm { src 1 } { obj 2 } { slot 9 } { tag 2 } }
T{ ##write-barrier-imm
T{ set-slot-imm## { src 1 } { obj 2 } { slot 9 } { tag 2 } }
T{ write-barrier-imm##
{ src 2 }
{ slot 9 }
{ tag 2 }

12
basis/compiler/cfg/intrinsics/slots/slots.factor
View File

@ -44,22 +44,22 @@ IN: compiler.cfg.intrinsics.slots
2inputs :> ( src obj )
src obj slot tag ##set-slot-imm,
src obj slot tag set-slot-imm##,
write-barrier?
[ obj slot tag next-vreg next-vreg ##write-barrier-imm, ] when ;
[ obj slot tag next-vreg next-vreg write-barrier-imm##, ] when ;
:: (emit-set-slot) ( write-barrier? tag -- )
3inputs :> ( src obj slot )
slot tag slot-indexing :> ( slot scale tag )
src obj slot scale tag ##set-slot,
src obj slot scale tag set-slot##,
write-barrier?
[ obj slot scale tag next-vreg next-vreg ##write-barrier, ] when ;
[ obj slot scale tag next-vreg next-vreg write-barrier##, ] when ;
: node>set-slot-data ( #call -- write-barrier? tag literal )
: node>set-slot-data ( call# -- write-barrier? tag literal )
node-input-infos first3
[ class>> immediate class<= not ] [ value-tag ] [ literal>> ] tri* ;
@ -68,7 +68,7 @@ IN: compiler.cfg.intrinsics.slots
(emit-set-slot-imm)
] [ drop (emit-set-slot) ] if ;
: emit-set-slot ( block #call -- block' )
: emit-set-slot ( block call# -- block' )
dup node>set-slot-data over [
emit-intrinsic-set-slot drop
] [ 3drop emit-primitive ] if ;

6
basis/compiler/cfg/intrinsics/strings/strings-tests.factor
View File

@ -5,9 +5,9 @@ IN: compiler.cfg.intrinsics.strings.tests
{
V{
T{ ##tagged>integer { dst 4 } { src 3 } }
T{ ##add { dst 5 } { src1 4 } { src2 2 } }
T{ ##store-memory-imm
T{ tagged>integer## { dst 4 } { src 3 } }
T{ add## { dst 5 } { src1 4 } { src2 2 } }
T{ store-memory-imm##
{ src 1 }
{ base 5 }
{ offset "varies" }

2
basis/compiler/cfg/intrinsics/strings/strings.factor
View File

@ -11,4 +11,4 @@ IN: compiler.cfg.intrinsics.strings
2inputs (string-nth) ^^load-memory-imm ds-push ;
: emit-set-string-nth-fast ( -- )
3inputs (string-nth) ##store-memory-imm, ;
3inputs (string-nth) store-memory-imm##, ;

2
basis/compiler/cfg/linear-scan/allocation/allocation-docs.factor
View File

@ -55,7 +55,7 @@ HELP: spill-at-sync-point?
{ "live-interval" live-interval-state }
{ "?" boolean }
}
{ $description "Whether the given live interval must be spilled at the sync point. If the instruction for the given sync point is a " { $link hairy-clobber-insn } ", such as a (" { $link ##call-gc } " instruction) then the interval is always spilled." } ;
{ $description "Whether the given live interval must be spilled at the sync point. If the instruction for the given sync point is a " { $link hairy-clobber-insn } ", such as a (" { $link call-gc## } " instruction) then the interval is always spilled." } ;
ARTICLE: "compiler.cfg.linear-scan.allocation" "Allocating registers for live intervals"
"This vocab implements the step in the linear scan algorithm in which virtual registers are allocated physical registers. It also takes decisions on when to spill registers."

18
basis/compiler/cfg/linear-scan/assignment/assignment-docs.factor
View File

@ -12,7 +12,7 @@ HELP: add-pending
HELP: assign-registers-in-block
{ $values { "bb" basic-block } }
{ $description "Assigns registers to vregs and also inserts " { $link ##reload } " and " { $link ##spill } " instructions." } ;
{ $description "Assigns registers to vregs and also inserts " { $link reload## } " and " { $link spill## } " instructions." } ;
HELP: assign-registers
{ $values { "cfg" cfg } { "live-intervals" sequence } }
@ -31,22 +31,22 @@ HELP: compute-live-in
{ $description "Computes the live in registers for a basic block." }
{ $see-also machine-live-ins } ;
HELP: emit-##call-gc
{ $values { "insn" ##call-gc } }
{ $description "Emits a " { $link ##call-gc } " instruction and the " { $link ##reload } " and " { $link ##spill } " instructions it requires. ##call-gc aren't counted as sync points, so the instruction requires special handling." } ;
HELP: emit-call-gc##
{ $values { "insn" call-gc## } }
{ $description "Emits a " { $link call-gc## } " instruction and the " { $link reload## } " and " { $link spill## } " instructions it requires. call-gc## aren't counted as sync points, so the instruction requires special handling." } ;
HELP: expire-old-intervals
{ $values { "n" integer } { "pending-heap" min-heap } }
{ $description "Expires all intervals older than the cutoff point. First they are removed from the 'pending-heap' and " { $link pending-interval-assoc } ". Then " { $link ##spill } " instructions are inserted for each interval that was removed." } ;
{ $description "Expires all intervals older than the cutoff point. First they are removed from the 'pending-heap' and " { $link pending-interval-assoc } ". Then " { $link spill## } " instructions are inserted for each interval that was removed." } ;
HELP: insert-reload
{ $values { "live-interval" live-interval-state } }
{ $description "Inserts a " { $link ##reload } " instruction for a live interval." }
{ $description "Inserts a " { $link reload## } " instruction for a live interval." }
{ $see-also handle-reload insert-spill } ;
HELP: insert-spill
{ $values { "live-interval" live-interval-state } }
{ $description "Inserts a " { $link ##spill } " instruction for a live interval." }
{ $description "Inserts a " { $link spill## } " instruction for a live interval." }
{ $see-also insert-reload } ;
HELP: machine-edge-live-ins
@ -82,12 +82,12 @@ HELP: vreg>spill-slot
ARTICLE: "compiler.cfg.linear-scan.assignment" "Assigning registers to live intervals"
"The " { $vocab-link "compiler.cfg.linear-scan.assignment" } " assigns registers to live intervals. Before this compiler pass, all values in the " { $link cfg } " were represented as simple integers called \"virtual registers\" or vregs. In this pass, using the live interval data computed in the register allocation pass (" { $vocab-link "compiler.cfg.linear-scan.allocation" } "), those vregs are translated into physical registers."
$nl
"Since there is an infinite number of vregs but the number of physical registers is limited, some values must be spilled. So this pass also handles spilling decisions and inserts " { $link ##spill } " and " { $link ##reload } " instructions where needed."
"Since there is an infinite number of vregs but the number of physical registers is limited, some values must be spilled. So this pass also handles spilling decisions and inserts " { $link spill## } " and " { $link reload## } " instructions where needed."
$nl
"GC maps:"
{ $subsections
change-insn-gc-roots
emit-##call-gc
emit-call-gc##
}
"Pending intervals:"
{ $subsections

32
basis/compiler/cfg/linear-scan/assignment/assignment-tests.factor
View File

@ -26,7 +26,7 @@ IN: compiler.cfg.linear-scan.assignment.tests
! activate-new-intervals
{
{
T{ ##reload
T{ reload##
{ dst RBX }
{ rep tagged-rep }
{ src T{ spill-slot } }
@ -52,40 +52,40 @@ IN: compiler.cfg.linear-scan.assignment.tests
! assign-insn-defs
{
T{ ##peek { dst RAX } { loc T{ ds-loc } } { insn# 0 } }
T{ peek## { dst RAX } { loc T{ ds-loc } } { insn# 0 } }
} [
H{ { 37 RAX } } pending-interval-assoc set
{ { 37 int-rep 37 f } } setup-vreg-spills
T{ ##peek f 37 d: 0 0 } [ assign-insn-defs ] keep
T{ peek## f 37 d: 0 0 } [ assign-insn-defs ] keep
] unit-test
! assign-all-registers
{
T{ ##replace-imm f 20 d: 0 f }
T{ ##replace f RAX d: 0 f }
T{ replace-imm## f 20 d: 0 f }
T{ replace## f RAX d: 0 f }
} [
! It doesn't do anything because ##replace-imm isn't a vreg-insn.
T{ ##replace-imm { src 20 } { loc d: 0 } } [ assign-all-registers ] keep
! It doesn't do anything because replace-imm## isn't a vreg-insn.
T{ replace-imm## { src 20 } { loc d: 0 } } [ assign-all-registers ] keep
! This one does something.
H{ { 37 RAX } } pending-interval-assoc set
H{ { 37 37 } } leader-map set
T{ ##replace { src 37 } { loc d: 0 } } clone
T{ replace## { src 37 } { loc d: 0 } } clone
[ assign-all-registers ] keep
] unit-test
! assign-registers
{ } [
V{ T{ ##inc { loc d: 3 } { insn# 7 } } } 0 insns>block block>cfg { }
V{ T{ inc## { loc d: 3 } { insn# 7 } } } 0 insns>block block>cfg { }
assign-registers
] unit-test
! assign-registers-in-block
{
V{ T{ ##inc { loc T{ ds-loc { n 3 } } } { insn# 7 } } }
V{ T{ inc## { loc T{ ds-loc { n 3 } } } { insn# 7 } } }
} [
{ } init-assignment
V{ T{ ##inc { loc d: 3 } { insn# 7 } } } 0 insns>block
V{ T{ inc## { loc d: 3 } { insn# 7 } } } 0 insns>block
[ assign-registers-in-block ] keep instructions>>
] unit-test
@ -99,7 +99,7 @@ IN: compiler.cfg.linear-scan.assignment.tests
! insert-reload
{
{ T{ ##reload { dst RAX } { rep int-rep } { src T{ spill-slot } } } }
{ T{ reload## { dst RAX } { rep int-rep } { src T{ spill-slot } } } }
} [
[
T{ live-interval-state
@ -111,13 +111,13 @@ IN: compiler.cfg.linear-scan.assignment.tests
] unit-test
! insert-spill
{ { T{ ##spill { src RAX } } } } [
{ { T{ spill## { src RAX } } } } [
[
T{ live-interval-state { vreg 1234 } { reg RAX } } insert-spill
] { } make
] unit-test
{ V{ T{ ##spill { src RAX } { rep int-rep } } } } [
{ V{ T{ spill## { src RAX } { rep int-rep } } } } [
[
1234 <live-interval>
RAX >>reg int-rep >>spill-rep
@ -130,9 +130,9 @@ IN: compiler.cfg.linear-scan.assignment.tests
! The interval should be spilled around the gc instruction at 128. And
! it's spill representation should be int-rep because on instruction
! 102 it was converted from a tagged-rep to an int-rep.
: test-call-gc ( -- ##call-gc )
: test-call-gc ( -- call-gc## )
T{ gc-map { gc-roots { 149 109 110 } } { derived-roots V{ } } } 128
##call-gc boa ;
call-gc## boa ;
: test-interval ( -- live-interval )
T{ live-interval-state

14
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -20,7 +20,7 @@ SYMBOL: pending-interval-heap
SYMBOL: pending-interval-assoc
: insert-spill ( live-interval -- )
[ reg>> ] [ spill-rep>> ] [ spill-to>> ] tri ##spill, ;
[ reg>> ] [ spill-rep>> ] [ spill-to>> ] tri spill##, ;
: handle-spill ( live-interval -- )
dup spill-to>> [ insert-spill ] [ drop ] if ;
@ -77,7 +77,7 @@ SYMBOL: machine-live-outs
[ > ] with heap-pop-while [ expire-interval ] each ;
: insert-reload ( live-interval -- )
[ reg>> ] [ reload-rep>> ] [ reload-from>> ] tri ##reload, ;
[ reg>> ] [ reload-rep>> ] [ reload-from>> ] tri reload##, ;
: handle-reload ( live-interval -- )
dup reload-from>> [ insert-reload ] [ drop ] if ;
@ -126,19 +126,19 @@ RENAMING: assign "[ vreg>reg ]" "[ vreg>reg ]" "[ vreg>reg ]"
: spill/reloads ( n intervals -- spill/reloads )
[ spill/reload ] with map ;
: spill/reloads-for-call-gc ( ##call-gc -- spill-seq )
: spill/reloads-for-call-gc ( call-gc## -- spill-seq )
[ gc-map>> gc-roots>> ] [ insn#>> ] bi
[ spill-intervals ] keep swap spill/reloads ;
: emit-##call-gc ( insn -- )
: emit-call-gc## ( insn -- )
dup spill/reloads-for-call-gc
dup [ first3 ##spill, ] each
dup [ first3 spill##, ] each
swap ,
[ first3 ##reload, ] each ;
[ first3 reload##, ] each ;
: emit-gc-map-insn ( gc-map-insn -- )
[ [ leader ] change-insn-gc-roots ]
[ dup ##call-gc? [ emit-##call-gc ] [ , ] if ]
[ dup call-gc##? [ emit-call-gc## ] [ , ] if ]
[ [ vreg>spill-slot ] change-insn-gc-roots ] tri ;
: emit-insn ( insn -- )

6
basis/compiler/cfg/linear-scan/linear-scan-tests.factor
View File

@ -32,9 +32,9 @@ check-numbering? on
! A value is defined and never used; make sure it has the right
! live range
{
T{ ##load-integer f 1 0 }
T{ ##replace-imm f d: 0 "hi" }
T{ ##branch }
T{ load-integer## f 1 0 }
T{ replace-imm## f d: 0 "hi" }
T{ branch## }
} insns>cfg
[ cfg set ] [ number-instructions ] [ compute-live-intervals ] tri
drop ;

2
basis/compiler/cfg/linear-scan/live-intervals/live-intervals-docs.factor
View File

@ -56,7 +56,7 @@ HELP: from
HELP: hairy-clobber-insn
{ $class-description "Instructions that clobber registers. They receive inputs and produce outputs in spill slots." }
{ $notes "The " { $link ##call-gc } " instruction is not included in the class even though it clobbers registers because it is handled specially." } ;
{ $notes "The " { $link call-gc## } " instruction is not included in the class even though it clobbers registers because it is handled specially." } ;
HELP: insn>sync-point
{ $values { "insn" insn } { "sync-point/f" { $maybe sync-point } } }

10
basis/compiler/cfg/linear-scan/live-intervals/live-intervals-tests.factor
View File

@ -27,8 +27,8 @@ IN: compiler.cfg.linear-scan.live-intervals.tests
}
} [
V{
T{ ##call-gc }
T{ ##callback-inputs }
T{ call-gc## }
T{ callback-inputs## }
} insns>cfg
[ number-instructions ] [ cfg>sync-points ] bi
] unit-test
@ -106,9 +106,9 @@ IN: compiler.cfg.linear-scan.live-intervals.tests
! insn>sync-point
{ f f t } [
T{ ##call-gc } insn>sync-point
T{ ##callback-outputs } insn>sync-point keep-dst?>>
T{ ##unbox } insn>sync-point keep-dst?>>
T{ call-gc## } insn>sync-point
T{ callback-outputs## } insn>sync-point keep-dst?>>
T{ unbox## } insn>sync-point keep-dst?>>
] unit-test
! intervals-intersect?

12
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

@ -88,15 +88,15 @@ M: insn compute-live-intervals* drop ;
UNION: hairy-clobber-insn
alien-call-insn
##callback-inputs
##callback-outputs
##unbox-long-long ;
callback-inputs##
callback-outputs##
unbox-long-long## ;
UNION: clobber-insn
hairy-clobber-insn
##unbox
##box
##box-long-long ;
unbox##
box##
box-long-long## ;
M: vreg-insn compute-live-intervals* ( insn -- )
dup insn#>>

44
basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
View File

@ -18,7 +18,7 @@ IN: compiler.cfg.linear-scan.resolve.tests
{
{
T{ ##reload { dst 1 } { rep int-rep } { src T{ spill-slot f 0 } } }
T{ reload## { dst 1 } { rep int-rep } { src T{ spill-slot f 0 } } }
}
} [
[
@ -30,7 +30,7 @@ IN: compiler.cfg.linear-scan.resolve.tests
{
{
T{ ##spill { src 1 } { rep int-rep } { dst T{ spill-slot f 0 } } }
T{ spill## { src 1 } { rep int-rep } { dst T{ spill-slot f 0 } } }
}
} [
[
@ -42,7 +42,7 @@ IN: compiler.cfg.linear-scan.resolve.tests
{
{
T{ ##copy { src 1 } { dst 2 } { rep int-rep } }
T{ copy## { src 1 } { dst 2 } { rep int-rep } }
}
} [
[
@ -54,8 +54,8 @@ IN: compiler.cfg.linear-scan.resolve.tests
{
{
T{ ##copy { src 1 } { dst 2 } { rep int-rep } }
T{ ##branch }
T{ copy## { src 1 } { dst 2 } { rep int-rep } }
T{ branch## }
}
} [
{ { T{ location f 1 int-rep int-regs } T{ location f 2 int-rep int-regs } } }
@ -64,9 +64,9 @@ IN: compiler.cfg.linear-scan.resolve.tests
{
{
T{ ##spill { src 0 } { rep int-rep } { dst T{ spill-slot f 0 } } }
T{ ##reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 1 } } }
T{ ##branch }
T{ spill## { src 0 } { rep int-rep } { dst T{ spill-slot f 0 } } }
T{ reload## { dst 0 } { rep tagged-rep } { src T{ spill-slot f 1 } } }
T{ branch## }
}
} [
{
@ -78,9 +78,9 @@ IN: compiler.cfg.linear-scan.resolve.tests
{
{
T{ ##spill { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
T{ ##reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
T{ ##branch }
T{ spill## { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
T{ reload## { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
T{ branch## }
}
} [
{
@ -92,9 +92,9 @@ IN: compiler.cfg.linear-scan.resolve.tests
{
{
T{ ##spill { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
T{ ##reload { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
T{ ##branch }
T{ spill## { src 0 } { rep int-rep } { dst T{ spill-slot f 1 } } }
T{ reload## { dst 0 } { rep tagged-rep } { src T{ spill-slot f 0 } } }
T{ branch## }
}
} [
{
@ -114,16 +114,16 @@ init-resolve
}
mapping-instructions {
{
T{ ##spill { src 0 } { rep int-rep } { dst T{ spill-slot f 8 } } }
T{ ##copy { dst 0 } { src 1 } { rep int-rep } }
T{ ##reload { dst 1 } { rep int-rep } { src T{ spill-slot f 8 } } }
T{ ##branch }
T{ spill## { src 0 } { rep int-rep } { dst T{ spill-slot f 8 } } }
T{ copy## { dst 0 } { src 1 } { rep int-rep } }
T{ reload## { dst 1 } { rep int-rep } { src T{ spill-slot f 8 } } }
T{ branch## }
}
{
T{ ##spill { src 1 } { rep int-rep } { dst T{ spill-slot f 8 } } }
T{ ##copy { dst 1 } { src 0 } { rep int-rep } }
T{ ##reload { dst 0 } { rep int-rep } { src T{ spill-slot f 8 } } }
T{ ##branch }
T{ spill## { src 1 } { rep int-rep } { dst T{ spill-slot f 8 } } }
T{ copy## { dst 1 } { src 0 } { rep int-rep } }
T{ reload## { dst 0 } { rep int-rep } { src T{ spill-slot f 8 } } }
T{ branch## }
}
} member?
] unit-test

8
basis/compiler/cfg/linear-scan/resolve/resolve.factor
View File

@ -63,13 +63,13 @@ SYMBOL: temp-locations
] if ;
: memory->register ( from to -- )
swap [ reg>> ] [ [ rep>> ] [ reg>> ] bi ] bi* ##reload, ;
swap [ reg>> ] [ [ rep>> ] [ reg>> ] bi ] bi* reload##, ;
: register->memory ( from to -- )
[ [ reg>> ] [ rep>> ] bi ] [ reg>> ] bi* ##spill, ;
[ [ reg>> ] [ rep>> ] bi ] [ reg>> ] bi* spill##, ;
: register->register ( from to -- )
swap [ reg>> ] [ [ reg>> ] [ rep>> ] bi ] bi* ##copy, ;
swap [ reg>> ] [ [ reg>> ] [ rep>> ] bi ] bi* copy##, ;
: >insn ( from to -- )
{
@ -81,7 +81,7 @@ SYMBOL: temp-locations
: mapping-instructions ( alist -- insns )
[ swap ] H{ } assoc-map-as [
[ temp-location ] [ swap >insn ] parallel-mapping
##branch,
branch##,
] { } make ;
: perform-mappings ( bb to mappings -- )

2
basis/compiler/cfg/liveness/liveness-docs.factor
View File

@ -72,7 +72,7 @@ $nl
{ $list
"With SSA, it is not sufficient to have a single live-in set per block. There is also an edge-live-in set per edge, consisting of phi inputs from each predecessor."
"Liveness analysis annotates call sites with GC maps indicating the spill slots in the stack frame that contain tagged pointers, and thus have to be visited if a GC occurs inside the call."
{ "GC maps can contain derived pointers. A derived pointer is a pointer into the middle of a data heap object. Each derived pointer has a base pointer, to keep it up to date when objects are moved by the garbage collector. This extends live intervals and inserts new " { $link ##phi } " instructions." }
{ "GC maps can contain derived pointers. A derived pointer is a pointer into the middle of a data heap object. Each derived pointer has a base pointer, to keep it up to date when objects are moved by the garbage collector. This extends live intervals and inserts new " { $link phi## } " instructions." }
}
$nl
"Querying liveness data:"

190
basis/compiler/cfg/liveness/liveness-tests.factor
View File

@ -18,7 +18,7 @@ IN: compiler.cfg.liveness.tests
}
} [
{
T{ ##phi
T{ phi##
{ dst 103 }
{ inputs H{ { "bl1" 7 } { "bl2" 99 } } }
}
@ -34,19 +34,19 @@ IN: compiler.cfg.liveness.tests
}
} [
{
T{ ##phi
T{ phi##
{ dst 196 }
{ inputs H{ { "b-26" 189 } { "b-23" 183 } { "b-31" 193 } } }
}
T{ ##phi
T{ phi##
{ dst 197 }
{ inputs H{ { "b-26" 190 } { "b-23" 182 } { "b-31" 194 } } }
}
T{ ##phi
T{ phi##
{ dst 198 }
{ inputs H{ { "b-26" 191 } { "b-23" 181 } { "b-31" 195 } } }
}
T{ ##phi
T{ phi##
{ dst 199 }
{ inputs H{ { "b-26" 188 } { "b-23" 187 } { "b-31" 192 } } }
}
@ -75,17 +75,17 @@ IN: compiler.cfg.liveness.tests
! gen-uses
{ H{ { 37 37 } } } [
H{ } clone [ T{ ##replace f 37 d: 0 0 } gen-uses ] keep
H{ } clone [ T{ replace## f 37 d: 0 0 } gen-uses ] keep
] unit-test
! kill-defs
{ H{ } } [
H{ } dup T{ ##peek f 37 d: 0 0 } kill-defs
H{ } dup T{ peek## f 37 d: 0 0 } kill-defs
] unit-test
{ H{ { 3 3 } } } [
H{ { 37 99 } { 99 99 } { 2 99 } } leader-map set
H{ { 37 37 } { 3 3 } } dup T{ ##peek f 2 d: 0 0 } kill-defs
H{ { 37 37 } { 3 3 } } dup T{ peek## f 2 d: 0 0 } kill-defs
] unit-test
! liveness-step
@ -101,28 +101,28 @@ IN: compiler.cfg.liveness.tests
] unit-test
{ 15 } [
{ T{ ##tagged>integer f 30 15 } } 0 insns>block block>cfg compute-live-sets
{ T{ tagged>integer## f 30 15 } } 0 insns>block block>cfg compute-live-sets
30 lookup-base-pointer
] unit-test
cpu x86.64? [
{ f } [
H{ } base-pointers set
H{ { 123 T{ ##peek { dst RCX } { loc d: 1 } { insn# 6 } } } } insns set
H{ { 123 T{ peek## { dst RCX } { loc d: 1 } { insn# 6 } } } } insns set
123 lookup-base-pointer
] unit-test
] when
! lookup-base-pointer*
{ f } [
456 T{ ##peek f 123 d: 0 } lookup-base-pointer*
456 T{ peek## f 123 d: 0 } lookup-base-pointer*
] unit-test
! transfer-liveness
{
H{ { 37 37 } }
} [
H{ } clone dup { T{ ##replace f 37 d: 1 6 } T{ ##peek f 37 d: 0 0 } }
H{ } clone dup { T{ replace## f 37 d: 1 6 } T{ peek## f 37 d: 0 0 } }
transfer-liveness
] unit-test
@ -141,23 +141,23 @@ cpu x86.64? [
! visit-insn
{ H{ } } [
H{ } clone [ T{ ##peek f 0 d: 0 } visit-insn ] keep
H{ } clone [ T{ peek## f 0 d: 0 } visit-insn ] keep
] unit-test
{ H{ { 48 48 } { 37 37 } } } [
H{ { 48 tagged-rep } } representations set
H{ { 48 48 } } clone [ T{ ##replace f 37 d: 1 6 } visit-insn ] keep
H{ { 48 48 } } clone [ T{ replace## f 37 d: 1 6 } visit-insn ] keep
] unit-test
{
T{ ##call-gc
T{ call-gc##
{ gc-map
T{ gc-map { gc-roots { 93 } } { derived-roots V{ } } }
}
}
} [
H{ { 93 tagged-rep } } representations set
H{ { 93 93 } } clone T{ ##call-gc f T{ gc-map } }
H{ { 93 93 } } clone T{ call-gc## f T{ gc-map } }
[ visit-insn ] keep
] unit-test
@ -167,21 +167,21 @@ cpu x86.64? [
! Sanity check...
V{
T{ ##peek f 0 d: 0 }
T{ ##replace f 0 d: 0 }
T{ ##replace f 1 d: 1 }
T{ ##peek f 1 d: 1 }
T{ ##branch }
T{ peek## f 0 d: 0 }
T{ replace## f 0 d: 0 }
T{ replace## f 1 d: 1 }
T{ peek## f 1 d: 1 }
T{ branch## }
} 1 test-bb
V{
T{ ##replace f 2 d: 0 }
T{ ##branch }
T{ replace## f 2 d: 0 }
T{ branch## }
} 2 test-bb
V{
T{ ##replace f 3 d: 0 }
T{ ##return }
T{ replace## f 3 d: 0 }
T{ return## }
} 3 test-bb
1 { 2 3 } edges
@ -201,13 +201,13 @@ unit-test
! Tricky case; defs must be killed before uses
V{
T{ ##peek f 0 d: 0 }
T{ ##branch }
T{ peek## f 0 d: 0 }
T{ branch## }
} 1 test-bb
V{
T{ ##add-imm f 0 0 10 }
T{ ##return }
T{ add-imm## f 0 0 10 }
T{ return## }
} 2 test-bb
1 2 edge
@ -218,74 +218,74 @@ V{
! Regression
V{
T{ ##prologue }
T{ ##branch }
T{ prologue## }
T{ branch## }
} 0 test-bb
V{
T{ ##inc { loc r: 2 } }
T{ ##inc { loc d: -2 } }
T{ ##peek f 21 d: -1 }
T{ ##peek f 22 d: -2 }
T{ ##replace f 21 r: 0 }
T{ ##replace f 22 r: 1 }
T{ ##branch }
T{ inc## { loc r: 2 } }
T{ inc## { loc d: -2 } }
T{ peek## f 21 d: -1 }
T{ peek## f 22 d: -2 }
T{ replace## f 21 r: 0 }
T{ replace## f 22 r: 1 }
T{ branch## }
} 1 test-bb
V{
T{ ##call f >c-ptr }
T{ ##branch }
T{ call## f >c-ptr }
T{ branch## }
} 2 test-bb
V{
T{ ##inc { loc r: -1 } }
T{ ##inc { loc d: 1 } }
T{ ##peek f 25 r: -1 }
T{ ##replace f 25 d: 0 }
T{ ##branch }
T{ inc## { loc r: -1 } }
T{ inc## { loc d: 1 } }
T{ peek## f 25 r: -1 }
T{ replace## f 25 d: 0 }
T{ branch## }
} 3 test-bb
V{
T{ ##call f >float }
T{ ##branch }
T{ call## f >float }
T{ branch## }
} 4 test-bb
V{
T{ ##inc f r: -1 }
T{ ##inc f d: 2 }
T{ ##peek f 27 r: -1 }
T{ ##peek f 28 d: 2 }
T{ ##peek f 29 d: 3 }
T{ ##load-integer f 30 1 }
T{ ##load-integer f 31 0 }
T{ ##compare-imm-branch f 27 f cc/= }
T{ inc## f r: -1 }
T{ inc## f d: 2 }
T{ peek## f 27 r: -1 }
T{ peek## f 28 d: 2 }
T{ peek## f 29 d: 3 }
T{ load-integer## f 30 1 }
T{ load-integer## f 31 0 }
T{ compare-imm-branch## f 27 f cc/= }
} 5 test-bb
V{
T{ ##inc f d: -1 }
T{ ##branch }
T{ inc## f d: -1 }
T{ branch## }
} 6 test-bb
V{
T{ ##inc f d: -1 }
T{ ##branch }
T{ inc## f d: -1 }
T{ branch## }
} 7 test-bb
V{
T{ ##phi f 36 H{ { 6 30 } { 7 31 } } }
T{ ##inc f d: -2 }
T{ ##unbox f 37 29 "alien_offset" int-rep }
T{ ##unbox f 38 28 "to_double" double-rep }
T{ ##unbox f 39 36 "to_cell" int-rep }
T{ ##alien-invoke f f V{ } V{ { 37 int-rep 0 } { 38 double-rep 4 } { 39 int-rep 12 } } { { 40 int-rep EAX } } { } 0 16 "CFRunLoopRunInMode" f T{ gc-map } }
T{ ##box f 41 40 "from_signed_cell" int-rep T{ gc-map } }
T{ ##replace f 41 d: 0 }
T{ ##branch }
T{ phi## f 36 H{ { 6 30 } { 7 31 } } }
T{ inc## f d: -2 }
T{ unbox## f 37 29 "alien_offset" int-rep }
T{ unbox## f 38 28 "to_double" double-rep }
T{ unbox## f 39 36 "to_cell" int-rep }
T{ alien-invoke## f f V{ } V{ { 37 int-rep 0 } { 38 double-rep 4 } { 39 int-rep 12 } } { { 40 int-rep EAX } } { } 0 16 "CFRunLoopRunInMode" f T{ gc-map } }
T{ box## f 41 40 "from_signed_cell" int-rep T{ gc-map } }
T{ replace## f 41 d: 0 }
T{ branch## }
} 8 test-bb
V{
T{ ##epilogue }
T{ ##return }
T{ epilogue## }
T{ return## }
} 9 test-bb
0 1 edge
@ -306,41 +306,41 @@ V{
{ H{ { 30 30 } } } [ 6 get 8 get edge-live-in ] unit-test
V{
T{ ##prologue }
T{ ##branch }
T{ prologue## }
T{ branch## }
} 0 test-bb
V{
T{ ##branch }
T{ branch## }
} 1 test-bb
V{
T{ ##load-integer f 0 0 }
T{ ##branch }
T{ load-integer## f 0 0 }
T{ branch## }
} 2 test-bb
V{
T{ ##load-integer f 1 1 }
T{ ##branch }
T{ load-integer## f 1 1 }
T{ branch## }
} 3 test-bb
V{
T{ ##phi f 2 H{ { 2 0 } { 3 1 } } }
T{ ##branch }
T{ phi## f 2 H{ { 2 0 } { 3 1 } } }
T{ branch## }
} 4 test-bb
V{
T{ ##branch }
T{ branch## }
} 5 test-bb
V{
T{ ##replace f 2 d: 0 }
T{ ##branch }
T{ replace## f 2 d: 0 }
T{ branch## }
} 6 test-bb
V{
T{ ##epilogue }
T{ ##return }
T{ epilogue## }
T{ return## }
} 7 test-bb
0 1 edge
@ -363,23 +363,23 @@ V{
V{
T{ ##prologue }
T{ ##branch }
T{ prologue## }
T{ branch## }
} 0 test-bb
V{
T{ ##peek f 0 d: 0 }
T{ ##tagged>integer f 1 0 }
T{ ##call-gc f T{ gc-map } }
T{ ##replace f 0 d: 0 }
T{ ##call-gc f T{ gc-map } }
T{ ##replace f 1 d: 0 }
T{ ##branch }
T{ peek## f 0 d: 0 }
T{ tagged>integer## f 1 0 }
T{ call-gc## f T{ gc-map } }
T{ replace## f 0 d: 0 }
T{ call-gc## f T{ gc-map } }
T{ replace## f 1 d: 0 }
T{ branch## }
} 1 test-bb
V{
T{ ##epilogue }
T{ ##return }
T{ epilogue## }
T{ return## }
} 2 test-bb
0 1 edge

18
basis/compiler/cfg/liveness/liveness.factor
View File

@ -42,30 +42,30 @@ DEFER: lookup-base-pointer
GENERIC: lookup-base-pointer* ( vreg insn -- vreg/f )
M: ##tagged>integer lookup-base-pointer* nip src>> ;
M: tagged>integer## lookup-base-pointer* nip src>> ;
M: ##unbox-any-c-ptr lookup-base-pointer*
M: unbox-any-c-ptr## lookup-base-pointer*
! If the input to unbox-any-c-ptr was an alien and not a
! byte array, then the derived pointer will be outside of
! the data heap. The GC has to handle this case and ignore
! it.
nip src>> ;
M: ##copy lookup-base-pointer* nip src>> lookup-base-pointer ;
M: copy## lookup-base-pointer* nip src>> lookup-base-pointer ;
M: ##add-imm lookup-base-pointer* nip src1>> lookup-base-pointer ;
M: add-imm## lookup-base-pointer* nip src1>> lookup-base-pointer ;
M: ##sub-imm lookup-base-pointer* nip src1>> lookup-base-pointer ;
M: sub-imm## lookup-base-pointer* nip src1>> lookup-base-pointer ;
M: ##parallel-copy lookup-base-pointer* values>> value-at ;
M: parallel-copy## lookup-base-pointer* values>> value-at ;
M: ##add lookup-base-pointer*
M: add## lookup-base-pointer*
! If both operands have a base pointer, then the user better
! not be doing memory reads and writes on the object, since
! we don't give it a base pointer in that case at all.
nip [ src1>> ] [ src2>> ] bi [ lookup-base-pointer ] bi@ xor ;
M: ##sub lookup-base-pointer*
M: sub## lookup-base-pointer*
nip src1>> lookup-base-pointer ;
M: vreg-insn lookup-base-pointer* 2drop f ;
@ -101,7 +101,7 @@ M: vreg-insn lookup-base-pointer* 2drop f ;
M: gc-map-insn visit-insn ( live-set insn -- )
[ kill-defs ] [ gc-map>> fill-gc-map ] [ gen-uses ] 2tri ;
M: ##phi visit-insn kill-defs ;
M: phi## visit-insn kill-defs ;
M: insn visit-insn 2drop ;

6
basis/compiler/cfg/parallel-copy/parallel-copy-docs.factor
View File

@ -9,16 +9,16 @@ HELP: process-to-do
HELP: parallel-copy
{ $values { "mapping" { $link assoc } " of { dst src } virtual register pairs" } { "insns" array } }
{ $description "Creates " { $link ##copy } " instructions." } ;
{ $description "Creates " { $link copy## } " instructions." } ;
HELP: parallel-copy-rep
{ $values { "mapping" { $link assoc } " of { dst src } virtual register pairs" } { "insns" array } }
{ $description "Creates " { $link ##copy } " instructions. Representation selection must have been run previously." } ;
{ $description "Creates " { $link copy## } " instructions. Representation selection must have been run previously." } ;
ARTICLE: "compiler.cfg.parallel-copy" "Parallel copy"
"Revisiting Out-of-SSA Translation for Correctness, Code Quality, and Efficiency http://hal.archives-ouvertes.fr/docs/00/34/99/25/PDF/OutSSA-RR.pdf, Algorithm 1"
$nl
"Generating " { $link ##copy } " instructions:"
"Generating " { $link copy## } " instructions:"
{ $subsections parallel-copy parallel-copy-rep } ;
ABOUT: "compiler.cfg.parallel-copy"

22
basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor
View File

@ -16,9 +16,9 @@ SYMBOL: temp
{
{
T{ ##copy f 4 2 any-rep }
T{ ##copy f 2 1 any-rep }
T{ ##copy f 1 4 any-rep }
T{ copy## f 4 2 any-rep }
T{ copy## f 2 1 any-rep }
T{ copy## f 1 4 any-rep }
}
} [
H{
@ -29,8 +29,8 @@ SYMBOL: temp
{
{
T{ ##copy f 1 2 any-rep }
T{ ##copy f 3 4 any-rep }
T{ copy## f 1 2 any-rep }
T{ copy## f 3 4 any-rep }
}
} [
H{
@ -41,8 +41,8 @@ SYMBOL: temp
{
{
T{ ##copy f 1 3 any-rep }
T{ ##copy f 2 1 any-rep }
T{ copy## f 1 3 any-rep }
T{ copy## f 2 1 any-rep }
}
} [
H{
@ -53,10 +53,10 @@ SYMBOL: temp
{
{
T{ ##copy f 4 3 any-rep }
T{ ##copy f 3 2 any-rep }
T{ ##copy f 2 1 any-rep }
T{ ##copy f 1 4 any-rep }
T{ copy## f 4 3 any-rep }
T{ copy## f 3 2 any-rep }
T{ copy## f 2 1 any-rep }
T{ copy## f 1 4 any-rep }
}
} [
{

4
basis/compiler/cfg/parallel-copy/parallel-copy.factor
View File

@ -52,7 +52,7 @@ PRIVATE>
] with-scope ; inline
: parallel-copy ( mapping -- insns )
[ next-vreg '[ drop _ ] [ any-rep ##copy, ] parallel-mapping ] { } make ;
[ next-vreg '[ drop _ ] [ any-rep copy##, ] parallel-mapping ] { } make ;
<PRIVATE
@ -67,5 +67,5 @@ PRIVATE>
: parallel-copy-rep ( mapping -- insns )
[
H{ } clone temp-vregs set
[ rep-of temp-vreg ] [ dup rep-of ##copy, ] parallel-mapping
[ rep-of temp-vreg ] [ dup rep-of copy##, ] parallel-mapping
] { } make ;

2
basis/compiler/cfg/predecessors/predecessors.factor
View File

@ -9,7 +9,7 @@ IN: compiler.cfg.predecessors
: update-predecessors ( bb -- )
dup successors>> [ predecessors>> push ] with each ;
: update-phi ( bb ##phi -- )
: update-phi ( bb phi## -- )
[
swap predecessors>>
'[ drop _ member-eq? ] assoc-filter

2
basis/compiler/cfg/registers/registers-docs.factor
View File

@ -18,7 +18,7 @@ HELP: next-vreg-rep
HELP: rep-of
{ $values { "vreg" number } { "rep" representation } }
{ $description "Gets the representation for a virtual register. This word cannot be called before representation selection has run; use any-rep for " { $link ##copy } " instructions and so on." }
{ $description "Gets the representation for a virtual register. This word cannot be called before representation selection has run; use any-rep for " { $link copy## } " instructions and so on." }
{ $notes
{ $list
{ "Throws " { $link bad-vreg } " if the representation for the vreg isn't known." }

14
basis/compiler/cfg/renaming/functor/functor.factor
View File

@ -21,25 +21,25 @@ INLINE-FUNCTOR: renaming ( name: name def-quot: string use-quot: string temp-quo
! Instructions with unusual operands
! Special ${name}-insn-defs methods
M: ##parallel-copy ${name}-insn-defs
M: parallel-copy## ${name}-insn-defs
[ [ first2 ${def-quot} dip 2array ] map ] change-values drop ;
M: ##phi ${name}-insn-defs ${def-quot} change-dst drop ;
M: phi## ${name}-insn-defs ${def-quot} change-dst drop ;
M: alien-call-insn ${name}-insn-defs
[ [ first3 ${def-quot} 2dip 3array ] map ] change-reg-outputs
drop ;
M: ##callback-inputs ${name}-insn-defs
M: callback-inputs## ${name}-insn-defs
[ [ first3 ${def-quot} 2dip 3array ] map ] change-reg-outputs
[ [ first3 ${def-quot} 2dip 3array ] map ] change-stack-outputs
drop ;
! Special ${name}-insn-uses methods
M: ##parallel-copy ${name}-insn-uses
M: parallel-copy## ${name}-insn-uses
[ [ first2 ${use-quot} call 2array ] map ] change-values drop ;
M: ##phi ${name}-insn-uses
M: phi## ${name}-insn-uses
[ ${use-quot} assoc-map ] change-inputs drop ;
M: alien-call-insn ${name}-insn-uses
@ -47,10 +47,10 @@ INLINE-FUNCTOR: renaming ( name: name def-quot: string use-quot: string temp-quo
[ [ first3 ${use-quot} 2dip 3array ] map ] change-stack-inputs
drop ;
M: ##alien-indirect ${name}-insn-uses
M: alien-indirect## ${name}-insn-uses
${use-quot} change-src call-next-method ;
M: ##callback-outputs ${name}-insn-uses
M: callback-outputs## ${name}-insn-uses
[ [ first3 ${use-quot} 2dip 3array ] map ] change-reg-inputs
drop ;

16
basis/compiler/cfg/representations/coalescing/coalescing-tests.factor
View File

@ -7,23 +7,23 @@ IN: compiler.cfg.representations.coalescing.tests
0 get block>cfg compute-components ;
V{
T{ ##prologue }
T{ ##branch }
T{ prologue## }
T{ branch## }
} 0 test-bb
V{
T{ ##peek f 2 d: 0 }
T{ ##load-integer f 0 0 }
T{ ##branch }
T{ peek## f 2 d: 0 }
T{ load-integer## f 0 0 }
T{ branch## }
} 1 test-bb
V{
T{ ##load-integer f 1 0 }
T{ ##branch }
T{ load-integer## f 1 0 }
T{ branch## }
} 2 test-bb
V{
T{ ##phi f 3 H{ { 1 0 } { 2 1 } } }
T{ phi## f 3 H{ { 1 0 } { 2 1 } } }
} 3 test-bb
0 { 1 2 } edges

6
basis/compiler/cfg/representations/coalescing/coalescing.factor
View File

@ -6,7 +6,7 @@ kernel namespaces sequences ;
IN: compiler.cfg.representations.coalescing
! Find all strongly connected components in the graph where the
! edges are ##phi or ##copy vreg uses
! edges are phi## or copy## vreg uses
SYMBOL: components
: init-components ( cfg components -- )
@ -18,10 +18,10 @@ SYMBOL: components
GENERIC#: visit-insn 1 ( insn disjoint-set -- )
M: ##copy visit-insn
M: copy## visit-insn
[ [ dst>> ] [ src>> ] bi ] dip equate ;
M: ##phi visit-insn
M: phi## visit-insn
[ [ inputs>> values ] [ dst>> ] bi ] dip equate-all-with ;
M: insn visit-insn 2drop ;

40
basis/compiler/cfg/representations/conversion/conversion.factor
View File

@ -11,73 +11,73 @@ GENERIC: rep>tagged ( dst src rep -- )
GENERIC: tagged>rep ( dst src rep -- )
M: int-rep rep>tagged ( dst src rep -- )
drop tag-bits get ##shl-imm, ;
drop tag-bits get shl-imm##, ;
M: int-rep tagged>rep ( dst src rep -- )
drop tag-bits get ##sar-imm, ;
drop tag-bits get sar-imm##, ;
M:: float-rep rep>tagged ( dst src rep -- )
double-rep next-vreg-rep :> temp
temp src ##single>double-float,
temp src single>double-float##,
dst temp double-rep rep>tagged ;
M:: float-rep tagged>rep ( dst src rep -- )
double-rep next-vreg-rep :> temp
temp src double-rep tagged>rep
dst temp ##double>single-float, ;
dst temp double>single-float##, ;
M:: double-rep rep>tagged ( dst src rep -- )
dst 16 float int-rep next-vreg-rep ##allot,
src dst float-offset double-rep f ##store-memory-imm, ;
dst 16 float int-rep next-vreg-rep allot##,
src dst float-offset double-rep f store-memory-imm##, ;
M: double-rep tagged>rep
drop float-offset double-rep f ##load-memory-imm, ;
drop float-offset double-rep f load-memory-imm##, ;
M:: vector-rep rep>tagged ( dst src rep -- )
tagged-rep next-vreg-rep :> temp
dst 16 2 cells + byte-array int-rep next-vreg-rep ##allot,
temp 16 tag-fixnum ##load-tagged,
temp dst 1 byte-array type-number ##set-slot-imm,
src dst byte-array-offset rep f ##store-memory-imm, ;
dst 16 2 cells + byte-array int-rep next-vreg-rep allot##,
temp 16 tag-fixnum load-tagged##,
temp dst 1 byte-array type-number set-slot-imm##,
src dst byte-array-offset rep f store-memory-imm##, ;
M: vector-rep tagged>rep
[ byte-array-offset ] dip f ##load-memory-imm, ;
[ byte-array-offset ] dip f load-memory-imm##, ;
M:: scalar-rep rep>tagged ( dst src rep -- )
tagged-rep next-vreg-rep :> temp
temp src rep ##scalar>integer,
temp src rep scalar>integer##,
dst temp int-rep rep>tagged ;
M:: scalar-rep tagged>rep ( dst src rep -- )
tagged-rep next-vreg-rep :> temp
temp src int-rep tagged>rep
dst temp rep ##integer>scalar, ;
dst temp rep integer>scalar##, ;
GENERIC: rep>int ( dst src rep -- )
GENERIC: int>rep ( dst src rep -- )
M: scalar-rep rep>int ( dst src rep -- )
##scalar>integer, ;
scalar>integer##, ;
M: scalar-rep int>rep ( dst src rep -- )
##integer>scalar, ;
integer>scalar##, ;
: emit-conversion ( dst src dst-rep src-rep -- )
{
{ [ 2dup eq? ] [ drop ##copy, ] }
{ [ 2dup eq? ] [ drop copy##, ] }
{ [ dup tagged-rep? ] [ drop tagged>rep ] }
{ [ over tagged-rep? ] [ nip rep>tagged ] }
{ [ dup int-rep? ] [ drop int>rep ] }
{ [ over int-rep? ] [ nip rep>int ] }
[
2dup 2array {
{ { double-rep float-rep } [ 2drop ##single>double-float, ] }
{ { float-rep double-rep } [ 2drop ##double>single-float, ] }
{ { double-rep float-rep } [ 2drop single>double-float##, ] }
{ { float-rep double-rep } [ 2drop double>single-float##, ] }
! Punning SIMD vector types? Naughty naughty! But
! it is allowed... otherwise bail out.
[
drop 2dup [ reg-class-of ] bi@ eq?
[ drop ##copy, ] [ bad-conversion ] if
[ drop copy##, ] [ bad-conversion ] if
]
} case
]

2
basis/compiler/cfg/representations/peephole/peephole-docs.factor
View File

@ -3,7 +3,7 @@ IN: compiler.cfg.representations.peephole
HELP: convert-to-zero-vector?
{ $values { "insn" insn } { "?" boolean } }
{ $description "When a literal zeroes/ones vector is unboxed, we replace the " { $link ##load-reference } " with a " { $link ##zero-vector } " or " { $link ##fill-vector } " instruction since this is more efficient." } ;
{ $description "When a literal zeroes/ones vector is unboxed, we replace the " { $link load-reference## } " with a " { $link zero-vector## } " or " { $link fill-vector## } " instruction since this is more efficient." } ;
ARTICLE: "compiler.cfg.representations.peephole" "Peephole optimizations"

74
basis/compiler/cfg/representations/peephole/peephole.factor
View File

@ -29,17 +29,17 @@ M: vreg-insn conversions-for-insn
M: vreg-insn optimize-insn
[ emit-use-conversion ] [ finish ] [ emit-def-conversion ] tri ;
M: ##load-integer optimize-insn
M: load-integer## optimize-insn
{
{
[ dup dst>> rep-of tagged-rep? ]
[ [ dst>> ] [ val>> tag-fixnum ] bi ##load-tagged, here ]
[ [ dst>> ] [ val>> tag-fixnum ] bi load-tagged##, here ]
}
[ call-next-method ]
} cond ;
! When a constant float is unboxed, we replace the
! ##load-reference with a ##load-float or ##load-double if the
! load-reference## with a load-float## or load-double## if the
! architecture supports it
: convert-to-load-float? ( insn -- ? )
{
@ -74,42 +74,42 @@ M: ##load-integer optimize-insn
[ obj>> B{ 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 255 } = ]
} 1&& ;
M: ##load-reference optimize-insn
M: load-reference## optimize-insn
{
{
[ dup convert-to-load-float? ]
[ [ dst>> ] [ obj>> ] bi ##load-float, here ]
[ [ dst>> ] [ obj>> ] bi load-float##, here ]
}
{
[ dup convert-to-load-double? ]
[ [ dst>> ] [ obj>> ] bi ##load-double, here ]
[ [ dst>> ] [ obj>> ] bi load-double##, here ]
}
{
[ dup convert-to-zero-vector? ]
[ dst>> dup rep-of ##zero-vector, here ]
[ dst>> dup rep-of zero-vector##, here ]
}
{
[ dup convert-to-fill-vector? ]
[ dst>> dup rep-of ##fill-vector, here ]
[ dst>> dup rep-of fill-vector##, here ]
}
{
[ dup convert-to-load-vector? ]
[ [ dst>> ] [ obj>> ] [ dst>> rep-of ] tri ##load-vector, here ]
[ [ dst>> ] [ obj>> ] [ dst>> rep-of ] tri load-vector##, here ]
}
[ call-next-method ]
} cond ;
! Optimize this:
! ##sar-imm temp src tag-bits
! ##shl-imm dst temp X
! sar-imm## temp src tag-bits
! shl-imm## dst temp X
! Into either
! ##shl-imm by X - tag-bits, or
! ##sar-imm by tag-bits - X.
! shl-imm## by X - tag-bits, or
! sar-imm## by tag-bits - X.
: combine-shl-imm-input ( insn -- )
[ dst>> ] [ src1>> ] [ src2>> ] tri tag-bits get {
{ [ 2dup < ] [ swap - ##sar-imm, here ] }
{ [ 2dup > ] [ - ##shl-imm, here ] }
[ 2drop int-rep ##copy, here ]
{ [ 2dup < ] [ swap - sar-imm##, here ] }
{ [ 2dup > ] [ - shl-imm##, here ] }
[ 2drop int-rep copy##, here ]
} cond ;
: dst-tagged? ( insn -- ? ) dst>> rep-of tagged-rep? ;
@ -122,7 +122,7 @@ M: ##load-reference optimize-insn
: >tagged-shift ( insn -- ) [ tag-bits get + ] change-src2 finish ; inline
M: ##shl-imm optimize-insn
M: shl-imm## optimize-insn
{
{
[ dup { [ dst-tagged? ] [ src1-tagged? ] } 1&& ]
@ -140,12 +140,12 @@ M: ##shl-imm optimize-insn
} cond ;
! Optimize this:
! ##sar-imm temp src tag-bits
! ##sar-imm dst temp X
! sar-imm## temp src tag-bits
! sar-imm## dst temp X
! Into
! ##sar-imm by X + tag-bits
! sar-imm## by X + tag-bits
! assuming X + tag-bits is a valid shift count.
M: ##sar-imm optimize-insn
M: sar-imm## optimize-insn
{
{
[ dup { [ src1-tagged? ] [ src2-tagged-shift-count? ] } 1&& ]
@ -158,7 +158,7 @@ M: ##sar-imm optimize-insn
! we have
! tag(untag(a) X untag(b)) = a X b
!
! so if all inputs and outputs of ##X or ##X-imm are tagged,
! so if all inputs and outputs of X## or X-imm## are tagged,
! don't have to insert any conversions
M: inert-tag-untag-insn optimize-insn
{
@ -191,7 +191,7 @@ M: inert-bitwise-tag-untag-insn optimize-insn
[ call-next-method ]
} cond ;
M: ##mul-imm optimize-insn
M: mul-imm## optimize-insn
{
{ [ dup { [ dst-tagged? ] [ src1-tagged? ] } 1&& ] [ unchanged ] }
{ [ dup { [ dst-tagged? ] [ src2-tagged-arithmetic? ] } 1&& ] [ >tagged-imm ] }
@ -199,49 +199,49 @@ M: ##mul-imm optimize-insn
} cond ;
! Similar optimization for comparison operators
M: ##compare-integer-imm optimize-insn
M: compare-integer-imm## optimize-insn
{
{ [ dup { [ src1-tagged? ] [ src2-tagged-arithmetic? ] } 1&& ] [ >tagged-imm ] }
[ call-next-method ]
} cond ;
M: ##test-imm optimize-insn
M: test-imm## optimize-insn
{
{ [ dup { [ src1-tagged? ] [ src2-tagged-bitwise? ] } 1&& ] [ >tagged-imm ] }
[ call-next-method ]
} cond ;
M: ##compare-integer-imm-branch optimize-insn
M: compare-integer-imm-branch## optimize-insn
{
{ [ dup { [ src1-tagged? ] [ src2-tagged-arithmetic? ] } 1&& ] [ >tagged-imm ] }
[ call-next-method ]
} cond ;
M: ##test-imm-branch optimize-insn
M: test-imm-branch## optimize-insn
{
{ [ dup { [ src1-tagged? ] [ src2-tagged-bitwise? ] } 1&& ] [ >tagged-imm ] }
[ call-next-method ]
} cond ;
M: ##compare-integer optimize-insn
M: compare-integer## optimize-insn
{
{ [ dup { [ src1-tagged? ] [ src2-tagged? ] } 1&& ] [ unchanged ] }
[ call-next-method ]
} cond ;
M: ##test optimize-insn
M: test## optimize-insn
{
{ [ dup { [ src1-tagged? ] [ src2-tagged? ] } 1&& ] [ unchanged ] }
[ call-next-method ]
} cond ;
M: ##compare-integer-branch optimize-insn
M: compare-integer-branch## optimize-insn
{
{ [ dup { [ src1-tagged? ] [ src2-tagged? ] } 1&& ] [ unchanged ] }
[ call-next-method ]
} cond ;
M: ##test-branch optimize-insn
M: test-branch## optimize-insn
{
{ [ dup { [ src1-tagged? ] [ src2-tagged? ] } 1&& ] [ unchanged ] }
[ call-next-method ]
@ -254,9 +254,9 @@ M: ##test-branch optimize-insn
[ dst>> ] [ src>> ] bi [ rep-of tagged-rep? ] both? ;
: combine-neg-tag ( insn -- )
[ dst>> ] [ src>> ] bi tag-bits get 2^ neg ##mul-imm, here ;
[ dst>> ] [ src>> ] bi tag-bits get 2^ neg mul-imm##, here ;
M: ##neg optimize-insn
M: neg## optimize-insn
{
{ [ dup inert-tag/untag-unary? ] [ unchanged ] }
{
@ -270,10 +270,10 @@ M: ##neg optimize-insn
! tag(not(untag(x))) = not(x) xor tag-mask
:: emit-tagged-not ( insn -- )
tagged-rep next-vreg-rep :> temp
temp insn src>> ##not,
insn dst>> temp tag-mask get ##xor-imm, here ;
temp insn src>> not##,
insn dst>> temp tag-mask get xor-imm##, here ;
M: ##not optimize-insn
M: not## optimize-insn
{
{
[ dup inert-tag/untag-unary? ]
@ -282,5 +282,5 @@ M: ##not optimize-insn
[ call-next-method ]
} cond ;
M: ##bit-count optimize-insn
M: bit-count## optimize-insn
[ no-use-conversion ] [ finish ] [ emit-def-conversion ] tri ;

10
basis/compiler/cfg/representations/preferred/preferred.factor
View File

@ -58,21 +58,21 @@ PRIVATE>
M: alien-call-insn defs-vreg-reps
reg-outputs>> [ second ] map ;
M: ##callback-inputs defs-vreg-reps
M: callback-inputs## defs-vreg-reps
[ reg-outputs>> ] [ stack-outputs>> ] bi append [ second ] map ;
M: ##callback-outputs defs-vreg-reps drop { } ;
M: callback-outputs## defs-vreg-reps drop { } ;
M: alien-call-insn uses-vreg-reps
[ reg-inputs>> ] [ stack-inputs>> ] bi append [ second ] map ;
M: ##alien-indirect uses-vreg-reps
M: alien-indirect## uses-vreg-reps
call-next-method int-rep prefix ;
M: ##callback-inputs uses-vreg-reps
M: callback-inputs## uses-vreg-reps
drop { } ;
M: ##callback-outputs uses-vreg-reps
M: callback-outputs## uses-vreg-reps
reg-inputs>> [ second ] map ;
[

764
basis/compiler/cfg/representations/representations-tests.factor
View File

File diff suppressed because it is too large Load Diff

2
basis/compiler/cfg/representations/rewrite/rewrite-docs.factor
View File

@ -11,4 +11,4 @@ HELP: conversions-for-block
HELP: insert-conversions
{ $values { "cfg" cfg } }
{ $description "The last step in " { $vocab-link "compiler.cfg.representations" } ". Here instructions such as " { $link ##shl-imm } " and " { $link ##shr-imm } " are inserted to convert between tagged and untagged value types." } ;
{ $description "The last step in " { $vocab-link "compiler.cfg.representations" } ". Here instructions such as " { $link shl-imm## } " and " { $link shr-imm## } " are inserted to convert between tagged and untagged value types." } ;

4
basis/compiler/cfg/representations/rewrite/rewrite.factor
View File

@ -78,9 +78,9 @@ RENAMING: convert "[ converted-value ]" "[ converted-value ]" "[ ]"
GENERIC: conversions-for-insn ( insn -- )
M: ##phi conversions-for-insn , ;
M: phi## conversions-for-insn , ;
M: ##copy conversions-for-insn , ;
M: copy## conversions-for-insn , ;
M: insn conversions-for-insn , ;

6
basis/compiler/cfg/representations/selection/selection-tests.factor
View File

@ -3,7 +3,7 @@ compiler.cfg.representations.selection tools.test ;
IN: compiler.cfg.representations.selection.tests
{ t t f } [
T{ ##load-integer } peephole-optimizable?
T{ ##shr-imm } peephole-optimizable?
T{ ##call } peephole-optimizable?
T{ load-integer## } peephole-optimizable?
T{ shr-imm## } peephole-optimizable?
T{ call## } peephole-optimizable?
] unit-test

60
basis/compiler/cfg/representations/selection/selection.factor
View File

@ -23,7 +23,7 @@ SYMBOL: vreg-reps
GENERIC: (collect-vreg-reps) ( insn -- )
M: ##load-reference (collect-vreg-reps)
M: load-reference## (collect-vreg-reps)
[ dst>> ] [ obj>> ] bi {
{ [ dup float? ] [ drop { float-rep double-rep } ] }
{ [ dup byte-array? ] [ drop vector-reps ] }
@ -73,44 +73,44 @@ SYMBOL: costs
] each ; inline
UNION: inert-tag-untag-insn
##add
##sub
##and
##or
##xor
##min
##max ;
add##
sub##
and##
or##
xor##
min##
max## ;
UNION: inert-arithmetic-tag-untag-insn
##add-imm
##sub-imm ;
add-imm##
sub-imm## ;
UNION: inert-bitwise-tag-untag-insn
##and-imm
##or-imm
##xor-imm ;
and-imm##
or-imm##
xor-imm## ;
UNION: peephole-optimizable
##load-integer
##load-reference
##neg
##not
load-integer##
load-reference##
neg##
not##
inert-tag-untag-insn
inert-arithmetic-tag-untag-insn
inert-bitwise-tag-untag-insn
##mul-imm
##shl-imm
##shr-imm
##sar-imm
##compare-integer-imm
##compare-integer
##compare-integer-imm-branch
##compare-integer-branch
##test-imm
##test
##test-imm-branch
##test-branch
##bit-count ;
mul-imm##
shl-imm##
shr-imm##
sar-imm##
compare-integer-imm##
compare-integer##
compare-integer-imm-branch##
compare-integer-branch##
test-imm##
test##
test-imm-branch##
test-branch##
bit-count## ;
GENERIC: compute-insn-costs ( insn -- )

10
basis/compiler/cfg/save-contexts/save-contexts-docs.factor
View File

@ -4,23 +4,23 @@ IN: compiler.cfg.save-contexts
HELP: insert-save-contexts
{ $values { "cfg" cfg } }
{ $description "Inserts " { $link ##save-context } " instructions in each " { $link basic-block } " in the cfg that needs them. Save contexts are needed after instructions that modify the context, or instructions that read parameter registers." }
{ $description "Inserts " { $link save-context## } " instructions in each " { $link basic-block } " in the cfg that needs them. Save contexts are needed after instructions that modify the context, or instructions that read parameter registers." }
{ $see-also insns-needs-save-context? } ;
HELP: insns-needs-save-context?
{ $values { "insns" sequence } { "?" boolean } }
{ $description "Whether to insert a " { $link ##save-context } " instruction in the given instruction sequence or not. Only instructions that can allocate memory mandates save contexts." }
{ $description "Whether to insert a " { $link save-context## } " instruction in the given instruction sequence or not. Only instructions that can allocate memory mandates save contexts." }
{ $see-also gc-map-insn } ;
HELP: save-context-offset
{ $values { "insns" sequence } { "n" integer } }
{ $description { $link ##save-context } " must be placed after instructions that modify the context, or instructions that read parameter registers." } ;
{ $description { $link save-context## } " must be placed after instructions that modify the context, or instructions that read parameter registers." } ;
ARTICLE: "compiler.cfg.save-contexts" "Insert context saves"
"Inserts " { $link ##save-context } " in blocks that need them. If an instruction does something that might trigger a GC sweep, such as calling a C function, then the context must be saved before."
"Inserts " { $link save-context## } " in blocks that need them. If an instruction does something that might trigger a GC sweep, such as calling a C function, then the context must be saved before."
$nl
"Main word:"
{ $subsections insert-save-contexts }
{ $notes "The " { $link ##call-gc } " instruction does not need a context save because the primitive implementing the instruction (" { $link minor-gc } ") already saves the context for us." } ;
{ $notes "The " { $link call-gc## } " instruction does not need a context save because the primitive implementing the instruction (" { $link minor-gc } ") already saves the context for us." } ;
ABOUT: "compiler.cfg.save-contexts"

42
basis/compiler/cfg/save-contexts/save-contexts-tests.factor
View File

@ -6,28 +6,28 @@ IN: compiler.cfg.save-contexts.tests
! insns-needs-save-context?
{ f f t } [
{
T{ ##call-gc }
T{ call-gc## }
} insns-needs-save-context?
{
T{ ##add f 1 2 3 }
T{ ##branch }
T{ add## f 1 2 3 }
T{ branch## }
} insns-needs-save-context?
{ T{ ##alien-invoke } } insns-needs-save-context?
{ T{ alien-invoke## } } insns-needs-save-context?
] unit-test
H{ } clone representations set
V{
T{ ##add f 1 2 3 }
T{ ##branch }
T{ add## f 1 2 3 }
T{ branch## }
} 0 test-bb
0 get [ insert-save-context ] change-instructions drop
{
V{
T{ ##add f 1 2 3 }
T{ ##branch }
T{ add## f 1 2 3 }
T{ branch## }
}
} [
0 get instructions>>
@ -36,8 +36,8 @@ V{
4 vreg-counter set-global
V{
T{ ##inc f d: 3 }
T{ ##box f 4 3 "from_signed_4" int-rep
T{ inc## f d: 3 }
T{ box## f 4 3 "from_signed_4" int-rep
T{ gc-map { gc-roots { } } }
}
} 0 test-bb
@ -46,9 +46,9 @@ V{
{
V{
T{ ##inc f d: 3 }
T{ ##save-context f 5 6 }
T{ ##box f 4 3 "from_signed_4" int-rep
T{ inc## f d: 3 }
T{ save-context## f 5 6 }
T{ box## f 4 3 "from_signed_4" int-rep
T{ gc-map { gc-roots { } } }
}
}
@ -57,17 +57,17 @@ V{
] unit-test
V{
T{ ##phi }
T{ ##box }
T{ phi## }
T{ box## }
} 0 test-bb
0 get [ insert-save-context ] change-instructions drop
{
V{
T{ ##phi }
T{ ##save-context f 7 8 }
T{ ##box }
T{ phi## }
T{ save-context## f 7 8 }
T{ box## }
}
} [
0 get instructions>>
@ -75,9 +75,9 @@ V{
{ 3 } [
V{
T{ ##phi }
T{ ##phi }
T{ ##phi }
T{ phi## }
T{ phi## }
T{ phi## }
T{ insn }
} save-context-offset
] unit-test

12
basis/compiler/cfg/save-contexts/save-contexts.factor
View File

@ -4,16 +4,16 @@ USING: compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo
cpu.architecture kernel sequences ;
IN: compiler.cfg.save-contexts
UNION: context-modifier ##phi ##inc ##callback-inputs ;
UNION: context-modifier phi## inc## callback-inputs## ;
: save-context-offset ( insns -- n )
[ context-modifier? not ] find drop ;
UNION: needs-save-context-insn
##alien-invoke
##alien-indirect
##box-long-long
##box ;
alien-invoke##
alien-indirect##
box-long-long##
box## ;
: insns-needs-save-context? ( insns -- ? )
[ needs-save-context-insn? ] any? ;
@ -23,7 +23,7 @@ UNION: needs-save-context-insn
[
int-rep next-vreg-rep
int-rep next-vreg-rep
##save-context new-insn
save-context## new-insn
] dip
[ save-context-offset ] keep
insert-nth

10
basis/compiler/cfg/ssa/construction/construction-docs.factor
View File

@ -2,12 +2,12 @@ USING: compiler.cfg compiler.cfg.instructions
compiler.cfg.ssa.construction.private help.markup help.syntax ;
IN: compiler.cfg.ssa.construction
HELP: <##phi>
{ $values { "vreg" "vreg" } { "bb" basic-block } { "##phi" ##phi } }
{ $description "Creates a new " { $link ##phi } " instruction given a vreg and a basic block." } ;
HELP: <phi##>
{ $values { "vreg" "vreg" } { "bb" basic-block } { "phi##" phi## } }
{ $description "Creates a new " { $link phi## } " instruction given a vreg and a basic block." } ;
HELP: phis
{ $var-description "Maps vregs to " { $link ##phi } " instructions." } ;
{ $var-description "Maps vregs to " { $link phi## } " instructions." } ;
HELP: used-vregs
{ $var-description "Worklist of used vregs, to calculate used phis." } ;
@ -19,7 +19,7 @@ HELP: defs-multi
{ $var-description "Set of vregs defined in more than one basic block." } ;
HELP: inserting-phis
{ $var-description "Maps basic blocks to sequences of " { $link ##phi } " instructions." } ;
{ $var-description "Maps basic blocks to sequences of " { $link phi## } " instructions." } ;
HELP: pushed
{ $var-description "Maps vregs to renaming stacks." } ;

100
basis/compiler/cfg/ssa/construction/construction-tests.factor
View File

@ -6,7 +6,7 @@ IN: compiler.cfg.ssa.construction.tests
! insert-phi-later
{
{ V{ T{ ##phi { dst 789 } { inputs H{ } } } } }
{ V{ T{ phi## { dst 789 } { inputs H{ } } } } }
} [
H{ } clone inserting-phis set
789 { } 0 insns>block insert-phi-later
@ -24,8 +24,8 @@ IN: compiler.cfg.ssa.construction.tests
! live-phi?
{ f t } [
HS{ 68 } live-phis set
T{ ##phi } live-phi?
T{ ##phi { dst 68 } } live-phi?
T{ phi## } live-phi?
T{ phi## { dst 68 } } live-phi?
] unit-test
@ -39,31 +39,31 @@ IN: compiler.cfg.ssa.construction.tests
construct-ssa ;
: clean-up-phis ( insns -- insns' )
[ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map ;
[ dup phi##? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map ;
! Test 1
reset-counters
V{
T{ ##load-integer f 1 100 }
T{ ##add-imm f 2 1 50 }
T{ ##add-imm f 2 2 10 }
T{ ##branch }
T{ load-integer## f 1 100 }
T{ add-imm## f 2 1 50 }
T{ add-imm## f 2 2 10 }
T{ branch## }
} 0 test-bb
V{
T{ ##load-integer f 3 3 }
T{ ##branch }
T{ load-integer## f 3 3 }
T{ branch## }
} 1 test-bb
V{
T{ ##load-integer f 3 4 }
T{ ##branch }
T{ load-integer## f 3 4 }
T{ branch## }
} 2 test-bb
V{
T{ ##replace f 3 d: 0 }
T{ ##return }
T{ replace## f 3 d: 0 }
T{ return## }
} 3 test-bb
0 { 1 2 } edges
@ -74,32 +74,32 @@ V{
{
V{
T{ ##load-integer f 1 100 }
T{ ##add-imm f 2 1 50 }
T{ ##add-imm f 3 2 10 }
T{ ##branch }
T{ load-integer## f 1 100 }
T{ add-imm## f 2 1 50 }
T{ add-imm## f 3 2 10 }
T{ branch## }
}
} [ 0 get instructions>> ] unit-test
{
V{
T{ ##load-integer f 4 3 }
T{ ##branch }
T{ load-integer## f 4 3 }
T{ branch## }
}
} [ 1 get instructions>> ] unit-test
{
V{
T{ ##load-integer f 5 4 }
T{ ##branch }
T{ load-integer## f 5 4 }
T{ branch## }
}
} [ 2 get instructions>> ] unit-test
{
V{
T{ ##phi f 6 H{ { 1 4 } { 2 5 } } }
T{ ##replace f 6 d: 0 }
T{ ##return }
T{ phi## f 6 H{ { 1 4 } { 2 5 } } }
T{ replace## f 6 d: 0 }
T{ return## }
}
} [
3 get instructions>>
@ -111,9 +111,9 @@ reset-counters
V{ } 0 test-bb
V{ } 1 test-bb
V{ T{ ##peek f 0 d: 0 } } 2 test-bb
V{ T{ ##peek f 0 d: 0 } } 3 test-bb
V{ T{ ##replace f 0 d: 0 } } 4 test-bb
V{ T{ peek## f 0 d: 0 } } 2 test-bb
V{ T{ peek## f 0 d: 0 } } 3 test-bb
V{ T{ replace## f 0 d: 0 } } 4 test-bb
V{ } 5 test-bb
V{ } 6 test-bb
@ -128,8 +128,8 @@ V{ } 6 test-bb
{
V{
T{ ##phi f 3 H{ { 2 1 } { 3 2 } } }
T{ ##replace f 3 d: 0 }
T{ phi## f 3 H{ { 2 1 } { 3 2 } } }
T{ replace## f 3 d: 0 }
}
} [
4 get instructions>>
@ -140,25 +140,25 @@ V{ } 6 test-bb
reset-counters
V{
T{ ##branch }
T{ branch## }
} 0 test-bb
V{
T{ ##load-integer f 3 3 }
T{ ##branch }
T{ load-integer## f 3 3 }
T{ branch## }
} 1 test-bb
V{
T{ ##load-integer f 3 4 }
T{ ##branch }
T{ load-integer## f 3 4 }
T{ branch## }
} 2 test-bb
V{
T{ ##branch }
T{ branch## }
} 3 test-bb
V{
T{ ##return }
T{ return## }
} 4 test-bb
0 { 1 2 3 } edges
@ -168,43 +168,43 @@ V{
{ } [ test-ssa ] unit-test
{ V{ } } [ 4 get instructions>> [ ##phi? ] filter ] unit-test
{ V{ } } [ 4 get instructions>> [ phi##? ] filter ] unit-test
! Test 4
reset-counters
V{
T{ ##branch }
T{ branch## }
} 0 test-bb
V{
T{ ##branch }
T{ branch## }
} 1 test-bb
V{
T{ ##load-integer f 0 4 }
T{ ##branch }
T{ load-integer## f 0 4 }
T{ branch## }
} 2 test-bb
V{
T{ ##load-integer f 0 4 }
T{ ##branch }
T{ load-integer## f 0 4 }
T{ branch## }
} 3 test-bb
V{
T{ ##branch }
T{ branch## }
} 4 test-bb
V{
T{ ##branch }
T{ branch## }
} 5 test-bb
V{
T{ ##branch }
T{ branch## }
} 6 test-bb
V{
T{ ##return }
T{ return## }
} 7 test-bb
0 { 1 6 } edges
@ -217,6 +217,6 @@ V{
{ } [ test-ssa ] unit-test
{ V{ } } [ 5 get instructions>> [ ##phi? ] filter ] unit-test
{ V{ } } [ 5 get instructions>> [ phi##? ] filter ] unit-test
{ V{ } } [ 7 get instructions>> [ ##phi? ] filter ] unit-test
{ V{ } } [ 7 get instructions>> [ phi##? ] filter ] unit-test

8
basis/compiler/cfg/ssa/construction/construction.factor
View File

@ -36,11 +36,11 @@ M: vreg-insn compute-insn-defs
SYMBOL: inserting-phis
: <##phi> ( vreg bb -- ##phi )
predecessors>> over '[ _ ] H{ } map>assoc ##phi new-insn ;
: <phi##> ( vreg bb -- phi## )
predecessors>> over '[ _ ] H{ } map>assoc phi## new-insn ;
: insert-phi-later ( vreg bb -- )
[ <##phi> ] keep inserting-phis get push-at ;
[ <phi##> ] keep inserting-phis get push-at ;
: compute-phis-for ( vreg bbs -- )
members merge-set [ insert-phi-later ] with each ;
@ -130,7 +130,7 @@ M: vreg-insn rename-insn
! Live phis
SYMBOL: live-phis
: live-phi? ( ##phi -- ? )
: live-phi? ( phi## -- ? )
dst>> live-phis get in? ;
: compute-live-phis ( -- )

8
basis/compiler/cfg/ssa/cssa/cssa-tests.factor
View File

@ -5,21 +5,21 @@ IN: compiler.cfg.ssa.cssa.tests
! insert-phi-copies
{
V{
T{ ##phi
T{ phi##
{ dst 103 }
{ inputs H{ { "bl1" 7 } { "bl2" 99 } } }
}
T{ ##parallel-copy { values V{ { 3 4 } } } }
T{ parallel-copy## { values V{ { 3 4 } } } }
}
} [
V{ { 3 4 } } phi-copies set
V{
T{ ##phi { dst 103 } { inputs H{ { "bl1" 7 } { "bl2" 99 } } } }
T{ phi## { dst 103 } { inputs H{ { "bl1" 7 } { "bl2" 99 } } } }
} 0 insns>block
[ insert-phi-copies ] keep instructions>>
] unit-test
! phi-copy-insn
{ T{ ##parallel-copy f V{ { 3 4 } } f } } [
{ T{ parallel-copy## f V{ { 3 4 } } f } } [
V{ { 3 4 } } phi-copy-insn
] unit-test

6
basis/compiler/cfg/ssa/cssa/cssa.factor
View File

@ -31,7 +31,7 @@ SYMBOLS: edge-copies phi-copies ;
] each ;
: insert-edge-copies ( from to copies -- )
[ ##parallel-copy, ##branch, ] { } make insert-basic-block ;
[ parallel-copy##, branch##, ] { } make insert-basic-block ;
: insert-all-edge-copies ( bb -- )
[ edge-copies get ] dip '[
@ -39,10 +39,10 @@ SYMBOLS: edge-copies phi-copies ;
] assoc-each ;
: phi-copy-insn ( copies -- insn )
f \ ##parallel-copy boa ;
f \ parallel-copy## boa ;
: end-of-phis ( insns -- i )
[ [ ##phi? not ] find drop ] [ length ] bi or ;
[ [ phi##? not ] find drop ] [ length ] bi or ;
: insert-phi-copies ( bb -- )
[

2
basis/compiler/cfg/ssa/destruction/coalescing/coalescing-docs.factor
View File

@ -42,7 +42,7 @@ HELP: try-eliminate-copies
{ $see-also try-eliminate-copy } ;
ARTICLE: "compiler.cfg.ssa.destruction.coalescing" "Vreg Coalescing"
"This compiler pass eliminates redundant vreg copies. Coalescing occurs in two steps. First all redundant copies in all " { $link ##tagged>integer } " and " { $link ##phi } " instructions are handled. Then those in other instructions like " { $link vreg-insn } ", " { $link ##copy } " and " { $link ##parallel-copy } "."
"This compiler pass eliminates redundant vreg copies. Coalescing occurs in two steps. First all redundant copies in all " { $link tagged>integer## } " and " { $link phi## } " instructions are handled. Then those in other instructions like " { $link vreg-insn } ", " { $link copy## } " and " { $link parallel-copy## } "."
$nl
"Main entry point:"
{ $subsections coalesce-cfg }

14
basis/compiler/cfg/ssa/destruction/coalescing/coalescing-tests.factor
View File

@ -48,18 +48,18 @@ IN: compiler.cfg.ssa.destruction.coalescing.tests
H{ { 65 65 } { 99 99 } { 62 62 } { 303 303 } }
} [
{
T{ ##load-vector
T{ load-vector##
{ dst 62 }
{ val B{ 0 0 0 0 0 0 0 64 0 0 0 0 0 0 52 64 } }
{ rep double-2-rep }
}
T{ ##add-vector
T{ add-vector##
{ dst 65 }
{ src1 62 }
{ src2 63 }
{ rep double-2-rep }
}
T{ ##allot
T{ allot##
{ dst 99 }
{ size 24 }
{ temp 303 }
@ -71,7 +71,7 @@ IN: compiler.cfg.ssa.destruction.coalescing.tests
{
H{ { 118 118 } }
} [
{ T{ ##phi { dst 118 } { inputs H{ { 4 120 } { 2 119 } } } } }
{ T{ phi## { dst 118 } { inputs H{ { 4 120 } { 2 119 } } } } }
[ insns>cfg compute-defs ] [ init-coalescing ] bi
leader-map get
] unit-test
@ -84,13 +84,13 @@ IN: compiler.cfg.ssa.destruction.coalescing.tests
! coalesce-later
{ V{ { 2 1 } } } [
[
T{ ##copy { src 1 } { dst 2 } { rep int-rep } } coalesce-later
T{ copy## { src 1 } { dst 2 } { rep int-rep } } coalesce-later
] V{ } make
] unit-test
{ V{ { 3 4 } { 7 8 } } } [
[
T{ ##parallel-copy { values V{ { 3 4 } { 7 8 } } } } coalesce-later
T{ parallel-copy## { values V{ { 3 4 } { 7 8 } } } } coalesce-later
] V{ } make
] unit-test
@ -105,7 +105,7 @@ IN: compiler.cfg.ssa.destruction.coalescing.tests
{ t } [
10 [
{ 2286 2287 2288 } unique leader-map set
2286 make-phi-inputs ##phi new-insn
2286 make-phi-inputs phi## new-insn
coalesce-now
2286 leader
] replicate all-equal?

10
basis/compiler/cfg/ssa/destruction/coalescing/coalescing.factor
View File

@ -12,7 +12,7 @@ IN: compiler.cfg.ssa.destruction.coalescing
SYMBOL: class-element-map
: value-of ( vreg -- value )
dup insn-of dup ##tagged>integer? [ nip src>> ] [ drop ] if ;
dup insn-of dup tagged>integer##? [ nip src>> ] [ drop ] if ;
: coalesce-elements ( merged follower leader -- )
class-element-map get [ delete-at ] [ set-at ] bi-curry bi* ;
@ -49,10 +49,10 @@ GENERIC: coalesce-now ( insn -- )
M: insn coalesce-now drop ;
M: ##tagged>integer coalesce-now
M: tagged>integer## coalesce-now
[ dst>> ] [ src>> ] bi t try-eliminate-copy ;
M: ##phi coalesce-now
M: phi## coalesce-now
[ dst>> ] [ inputs>> values ] bi zip-scalar
natural-sort t try-eliminate-copies ;
@ -65,10 +65,10 @@ M: alien-call-insn coalesce-later drop ;
M: vreg-insn coalesce-later
[ defs-vregs ] [ uses-vregs ] bi zip ?first [ , ] when* ;
M: ##copy coalesce-later
M: copy## coalesce-later
[ dst>> ] [ src>> ] bi 2array , ;
M: ##parallel-copy coalesce-later
M: parallel-copy## coalesce-later
values>> % ;
: eliminatable-copy? ( vreg1 vreg2 -- ? )

4
basis/compiler/cfg/ssa/destruction/destruction-docs.factor
View File

@ -5,7 +5,7 @@ IN: compiler.cfg.ssa.destruction
HELP: cleanup-cfg
{ $values { "cfg" cfg } }
{ $description "In this pass, useless copies are eliminated. " { $link ##phi } " instructions are removed and " { $link ##parallel-copy } " are transformed into regular " { $link ##copy } " instructions. Then for the copy instructions, which are ##copy and " { $link ##tagged>integer } " it is checked to see if the copy is useful. If it is not, the instruction is removed from the cfg." } ;
{ $description "In this pass, useless copies are eliminated. " { $link phi## } " instructions are removed and " { $link parallel-copy## } " are transformed into regular " { $link copy## } " instructions. Then for the copy instructions, which are copy## and " { $link tagged>integer## } " it is checked to see if the copy is useful. If it is not, the instruction is removed from the cfg." } ;
HELP: destruct-ssa
{ $values { "cfg" cfg } }
@ -17,7 +17,7 @@ $nl
"Because of the design of the register allocator, this pass has three peculiar properties."
{ $list
{ "Instead of renaming vreg usages in the CFG, a map from vregs to canonical representatives is computed. This allows the register allocator to use the original SSA names to get reaching definitions. See " { $link leader-map } "." }
{ "Useless " { $link ##copy } " instructions, and all " { $link ##phi } " instructions, are eliminated, so the register allocator does not have to remove any redundant operations." }
{ "Useless " { $link copy## } " instructions, and all " { $link phi## } " instructions, are eliminated, so the register allocator does not have to remove any redundant operations." }
{ "This pass computes live sets and fills out the " { $slot "gc-roots" } " slots of GC maps with " { $vocab-link "compiler.cfg.liveness" } ", so the linear scan register allocator does not need to compute liveness again." }
}
$nl

18
basis/compiler/cfg/ssa/destruction/destruction-tests.factor
View File

@ -17,23 +17,23 @@ IN: compiler.cfg.ssa.destruction.tests
! cleanup-insn
{
V{ T{ ##copy { dst 100 } { src 46 } } }
V{ T{ copy## { dst 100 } { src 46 } } }
} [
setup-leader/reps-scenario
T{ ##copy { src 46 } { dst 100 } } [ cleanup-insn ] V{ } make
T{ copy## { src 46 } { dst 100 } } [ cleanup-insn ] V{ } make
] unit-test
! I think the difference is because ##parallel-copy may encode a swap
! I think the difference is because parallel-copy## may encode a swap
! between two vregs.
{
V{ T{ ##copy { dst 47 } { src 45 } { rep double-2-rep } } }
V{ T{ copy## { dst 47 } { src 45 } { rep double-2-rep } } }
} [
setup-leader/reps-scenario
T{ ##parallel-copy { values V{ { 100 46 } } } } [ cleanup-insn ] V{ } make
T{ parallel-copy## { values V{ { 100 46 } } } } [ cleanup-insn ] V{ } make
] unit-test
{ V{ } } [
T{ ##parallel-copy { values V{ } } }
T{ parallel-copy## { values V{ } } }
[ cleanup-insn ] V{ } make
] unit-test
@ -42,7 +42,7 @@ IN: compiler.cfg.ssa.destruction.tests
H{ { 36 23 } { 23 23 } } leader-map set
H{ { 36 int-rep } { 37 tagged-rep } } representations set
V{
T{ ##alien-invoke
T{ alien-invoke##
{ reg-inputs V{ { 56 int-rep RDI } } }
{ stack-inputs V{ } }
{ reg-outputs { { 36 int-rep RAX } } }
@ -54,8 +54,8 @@ IN: compiler.cfg.ssa.destruction.tests
{ gc-map T{ gc-map } }
{ insn# 14 }
}
T{ ##call-gc { gc-map T{ gc-map } } }
T{ ##box-alien
T{ call-gc## { gc-map T{ gc-map } } }
T{ box-alien##
{ dst 37 }
{ src 36 }
{ temp 11 }

8
basis/compiler/cfg/ssa/destruction/destruction.factor
View File

@ -15,17 +15,17 @@ GENERIC: cleanup-insn ( insn -- )
: useful-copy? ( insn -- ? )
[ dst>> ] [ src>> ] bi leaders = not ; inline
M: ##copy cleanup-insn
M: copy## cleanup-insn
dup useful-copy? [ , ] [ drop ] if ;
M: ##parallel-copy cleanup-insn
M: parallel-copy## cleanup-insn
values>> [ leaders ] assoc-map [ first2 = ] reject
parallel-copy-rep % ;
M: ##tagged>integer cleanup-insn
M: tagged>integer## cleanup-insn
dup useful-copy? [ , ] [ drop ] if ;
M: ##phi cleanup-insn drop ;
M: phi## cleanup-insn drop ;
M: insn cleanup-insn , ;

Some files were not shown because too many files have changed in this diff Show More