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

Alien intrinsics can now deal with all aliens not just simple ones

release
Slava Pestov 2007-10-01 04:20:47 -04:00
parent d4a241d35b
commit 0035d42762
12 changed files with 136 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
core/alien/alien.factor
View File

@ -4,12 +4,22 @@ IN: alien
USING: assocs kernel math namespaces sequences system
byte-arrays bit-arrays float-arrays kernel.private tuples ;
! Some predicate classes used by the compiler for optimization
! purposes
PREDICATE: alien simple-alien
underlying-alien not ;
UNION: simple-c-ptr
simple-alien byte-array bit-array float-array POSTPONE: f ;
DEFER: pinned-c-ptr?
PREDICATE: alien pinned-alien
underlying-alien pinned-c-ptr? ;
UNION: pinned-c-ptr
alien POSTPONE: f ;
UNION: c-ptr
alien bit-array byte-array float-array POSTPONE: f ;

2
core/compiler/test/alien.factor
View File

@ -153,7 +153,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
alien-invoke code-gc 3 ;
[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
! [ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
FUNCTION: longlong ffi_test_21 long x long y ;

26
core/compiler/test/intrinsics.factor
View File

@ -357,16 +357,16 @@ cell 8 = [
[ 3 ] [ B{ 1 2 3 4 5 } 2 [ alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ [ B{ 1 2 3 4 5 } 2 alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ B{ 1 2 3 4 5 } 2 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ B{ 1 2 3 4 5 } 2 [ { simple-c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ B{ 1 2 3 4 5 } 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
[ ] [ B{ 1 2 3 4 5 } malloc-byte-array "b" set ] unit-test
[ t ] [ "b" get >boolean ] unit-test
"b" get [
[ 3 ] [ "b" get 2 [ alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ "b" get [ { simple-alien } declare 2 alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ "b" get [ { alien } declare 2 alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ "b" get 2 [ { simple-alien fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ "b" get 2 [ { simple-c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
[ 3 ] [ "b" get 2 [ { c-ptr fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
[ ] [ "b" get free ] unit-test
] when
@ -375,13 +375,13 @@ cell 8 = [
"s" get [
[ "hello world" ] [ "s" get <void*> [ { byte-array } declare *void* ] compile-1 alien>char-string ] unit-test
[ "hello world" ] [ "s" get <void*> [ { simple-c-ptr } declare *void* ] compile-1 alien>char-string ] unit-test
[ "hello world" ] [ "s" get <void*> [ { c-ptr } declare *void* ] compile-1 alien>char-string ] unit-test
[ ] [ "s" get free ] unit-test
] when
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { simple-alien } declare <void*> ] compile-1 *void* ] unit-test
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { simple-c-ptr } declare <void*> ] compile-1 *void* ] unit-test
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { alien } declare <void*> ] compile-1 *void* ] unit-test
[ ALIEN: 1234 ] [ ALIEN: 1234 [ { c-ptr } declare <void*> ] compile-1 *void* ] unit-test
[ f ] [ f [ { POSTPONE: f } declare <void*> ] compile-1 *void* ] unit-test
[ 252 ] [ B{ 1 2 3 -4 5 } 3 [ { byte-array fixnum } declare alien-unsigned-1 ] compile-1 ] unit-test
@ -416,3 +416,17 @@ cell 8 = [
[ t ] [ pi <float> [ { byte-array } declare *float ] compile-1 pi - abs 0.001 < ] unit-test
[ t ] [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-1 ] keep *double pi = ] unit-test
[ 4 ] [
2 B{ 1 2 3 4 5 6 } <displaced-alien> [
{ alien } declare 1 alien-unsigned-1
] compile-1
] unit-test
[
B{ 0 0 0 0 } [ { byte-array } declare <void*> ] compile-1
] unit-test-fails
[
B{ 0 0 0 0 } [ { c-ptr } declare <void*> ] compile-1
] unit-test-fails

25
core/compiler/test/templates-early.factor
View File

@ -132,3 +132,28 @@ SYMBOL: template-chosen
! This is empty since we didn't change the stack
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
] with-scope
! Regression
[
[ ] [ init-templates ] unit-test
! >r r>
[ ] [
1 phantom->r
1 phantom-r>
] unit-test
! This is empty since we didn't change the stack
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
! >r r>
[ ] [
1 phantom->r
1 phantom-r>
] unit-test
[ ] [ { object } set-operand-classes ] unit-test
! This is empty since we didn't change the stack
[ t ] [ [ end-basic-block ] { } make empty? ] unit-test
] with-scope

4
core/compiler/test/templates.factor
View File

@ -202,14 +202,14 @@ TUPLE: my-tuple ;
[ 1 t ] [
B{ 1 2 3 4 } [
{ simple-c-ptr } declare
{ c-ptr } declare
[ 0 alien-unsigned-1 ] keep type
] compile-1 byte-array type-number =
] unit-test
[ t ] [
B{ 1 2 3 4 } [
{ simple-c-ptr } declare
{ c-ptr } declare
0 alien-cell type
] compile-1 alien type-number =
] unit-test

44
core/cpu/ppc/architecture/architecture.factor
View File

@ -325,17 +325,33 @@ M: ppc-backend %unbox-f ( dst src -- )
drop 0 swap v>operand LI ;
M: ppc-backend %unbox-any-c-ptr ( dst src -- )
{ "is-f" "is-alien" "end" } [ define-label ] each
0 over v>operand f v>operand CMPI
"is-f" get BEQ
12 over v>operand header-offset LWZ
0 12 alien type-number tag-header CMPI
"is-alien" get BEQ
2dup %unbox-byte-array
"end" get B
"is-alien" resolve-label
2dup %unbox-alien
"end" get B
"is-f" resolve-label
%unbox-f
"end" resolve-label ;
{ "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in R12
0 12 LI
! Load object into R11
11 swap v>operand MR
! We come back here with displaced aliens
"start" resolve-label
! Is the object f?
0 11 f v>operand CMPI
! If so, done
"end" get BEQ
! Is the object an alien?
0 11 header-offset LWZ
0 0 alien type-number tag-header CMPI
"is-byte-array" get BNE
! If so, load the offset
0 11 alien-offset LWZ
! Add it to address being computed
12 12 0 ADD
! Now recurse on the underlying alien
11 11 underlying-alien-offset LWZ
"start" get B
"is-byte-array" resolve-label
! Add byte array address to address being computed
12 12 11 ADD
! Add an offset to start of byte array's data area
12 12 byte-array-offset ADDI
"end" resolve-label
! Done, store address in destination register
v>operand 12 MR ;

14
core/cpu/ppc/intrinsics/intrinsics.factor
View File

@ -609,7 +609,7 @@ IN: cpu.ppc.intrinsics
: alien-integer-get-template
H{
{ +input+ {
{ unboxed-c-ptr "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "value" } } }
@ -625,7 +625,7 @@ IN: cpu.ppc.intrinsics
H{
{ +input+ {
{ f "value" fixnum }
{ unboxed-c-ptr "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +clobber+ { "value" "offset" } }
@ -665,7 +665,7 @@ define-alien-integer-intrinsics
[ LWZ ] %alien-accessor
] H{
{ +input+ {
{ unboxed-c-ptr "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { unboxed-alien "value" } } }
@ -677,8 +677,8 @@ define-alien-integer-intrinsics
[ STW ] %alien-accessor
] H{
{ +input+ {
{ unboxed-c-ptr "value" simple-c-ptr }
{ unboxed-c-ptr "alien" simple-c-ptr }
{ unboxed-c-ptr "value" pinned-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +clobber+ { "offset" } }
@ -687,7 +687,7 @@ define-alien-integer-intrinsics
: alien-float-get-template
H{
{ +input+ {
{ unboxed-c-ptr "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { float "value" } } }
@ -699,7 +699,7 @@ define-alien-integer-intrinsics
H{
{ +input+ {
{ float "value" float }
{ unboxed-c-ptr "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +clobber+ { "offset" } }

43
core/cpu/x86/architecture/architecture.factor
View File

@ -183,16 +183,33 @@ M: x86-backend %unbox-f ( dst src -- )
drop v>operand 0 MOV ;
M: x86-backend %unbox-any-c-ptr ( dst src -- )
{ "is-f" "is-alien" "end" } [ define-label ] each
dup f [ v>operand ] 2apply CMP
"is-f" get JE
dup v>operand header-offset [+] alien type-number tag-header CMP
"is-alien" get JE
2dup %unbox-byte-array
"end" get JMP
"is-alien" resolve-label
2dup %unbox-alien
"end" get JMP
"is-f" resolve-label
%unbox-f
"end" resolve-label ;
{ "is-byte-array" "end" "start" } [ define-label ] each
! Address is computed in ds-reg
ds-reg PUSH
! Object is stored in ds-reg
rs-reg swap v>operand MOV
! We come back here with displaced aliens
"start" resolve-label
! Is the object f?
rs-reg f v>operand CMP
"end" get JE
! Is the object an alien?
rs-reg header-offset [+] alien type-number tag-header CMP
"is-byte-array" get JNE
! If so, load the offset and add it to the address
ds-reg rs-reg alien-offset [+] ADD
! Now recurse on the underlying alien
rs-reg rs-reg underlying-alien-offset [+] MOV
"start" get JMP
"is-byte-array" resolve-label
! Add byte array address to address being computed
ds-reg rs-reg ADD
! Add an offset to start of byte array's data
ds-reg byte-array-offset ADD
"end" resolve-label
! Done, store address in destination register
v>operand ds-reg MOV
! Restore rs-reg
rs-reg POP
! Restore ds-reg
ds-reg POP ;

10
core/cpu/x86/intrinsics/intrinsics.factor
View File

@ -514,7 +514,7 @@ IN: cpu.x86.intrinsics
: alien-integer-get-template
H{
{ +input+ {
{ unboxed-c-ptr "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { f "value" } } }
@ -546,7 +546,7 @@ IN: cpu.x86.intrinsics
H{
{ +input+ {
{ f "value" fixnum }
{ unboxed-c-ptr "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +clobber+ { "value" "offset" } }
@ -574,7 +574,7 @@ IN: cpu.x86.intrinsics
"value" operand [ MOV ] %alien-accessor
] H{
{ +input+ {
{ unboxed-c-ptr "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { unboxed-alien "value" } } }
@ -586,8 +586,8 @@ IN: cpu.x86.intrinsics
"value" operand [ swap MOV ] %alien-accessor
] H{
{ +input+ {
{ unboxed-c-ptr "value" simple-c-ptr }
{ unboxed-c-ptr "alien" simple-c-ptr }
{ unboxed-c-ptr "value" c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +clobber+ { "offset" } }

4
core/cpu/x86/sse2/sse2.factor
View File

@ -58,7 +58,7 @@ IN: cpu.x86.sse2
: alien-float-get-template
H{
{ +input+ {
{ unboxed-c-ptr "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +scratch+ { { float "value" } } }
@ -70,7 +70,7 @@ IN: cpu.x86.sse2
H{
{ +input+ {
{ float "value" float }
{ unboxed-c-ptr "alien" simple-c-ptr }
{ unboxed-c-ptr "alien" c-ptr }
{ f "offset" fixnum }
} }
{ +clobber+ { "offset" } }

1
core/generator/generator.factor
View File

@ -309,5 +309,6 @@ M: #return generate-node drop end-basic-block %return f ;
: profile-count-offset 7 cells object tag-number - ;
: byte-array-offset 2 cells object tag-number - ;
: alien-offset 3 cells object tag-number - ;
: underlying-alien-offset cell object tag-number - ;
: tuple-class-offset 2 cells tuple tag-number - ;
: class-hash-offset cell object tag-number - ;

6
core/generator/registers/registers.factor
View File

@ -146,7 +146,7 @@ INSTANCE: unboxed-alien value
TUPLE: unboxed-byte-array vreg ;
C: <unboxed-byte-array> unboxed-byte-array
M: unboxed-byte-array v>operand unboxed-byte-array-vreg v>operand ;
M: unboxed-byte-array operand-class* drop simple-c-ptr ;
M: unboxed-byte-array operand-class* drop c-ptr ;
M: unboxed-byte-array move-spec class ;
M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ;
@ -164,7 +164,7 @@ INSTANCE: unboxed-f value
TUPLE: unboxed-c-ptr vreg ;
C: <unboxed-c-ptr> unboxed-c-ptr
M: unboxed-c-ptr v>operand unboxed-c-ptr-vreg v>operand ;
M: unboxed-c-ptr operand-class* drop simple-c-ptr ;
M: unboxed-c-ptr operand-class* drop c-ptr ;
M: unboxed-c-ptr move-spec class ;
M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ;
@ -396,7 +396,7 @@ M: value (lazy-load)
drop ;
M: loc lazy-store
2dup = [ 2drop ] [ "live-locs" get at %move ] if ;
2dup live-loc? [ "live-locs" get at %move ] [ 2drop ] if ;
: do-shuffle ( hash -- )
dup assoc-empty? [