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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-09-13 20:48:42 -05:00
parent 38f375ee4b 2305117c21
commit 6be9308d65
11 changed files with 350 additions and 164 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
basis/alien/structs/structs.factor
View File

@ -18,20 +18,16 @@ M: struct-type c-type-align align>> ;
M: struct-type c-type-stack-align? drop f ;
M: struct-type unbox-parameter
[ heap-size %unbox-struct ]
[ unbox-parameter ]
if-value-structs? ;
[ %unbox-struct ] [ unbox-parameter ] if-value-structs? ;
M: struct-type unbox-return
f swap heap-size %unbox-struct ;
f swap %unbox-struct ;
M: struct-type box-parameter
[ heap-size %box-struct ]
[ box-parameter ]
if-value-structs? ;
[ %box-struct ] [ box-parameter ] if-value-structs? ;
M: struct-type box-return
f swap heap-size %box-struct ;
f swap %box-struct ;
M: struct-type stack-size
[ heap-size ] [ stack-size ] if-value-structs? ;

28
basis/compiler/generator/generator.factor
View File

@ -271,9 +271,7 @@ M: #return-recursive generate-node
! #alien-invoke
: large-struct? ( ctype -- ? )
dup c-struct? [
heap-size struct-small-enough? not
] [ drop f ] if ;
dup c-struct? [ struct-small-enough? not ] [ drop f ] if ;
: alien-parameters ( params -- seq )
dup parameters>>
@ -304,10 +302,10 @@ M: #return-recursive generate-node
alien-parameters parameter-sizes drop ;
: alien-invoke-frame ( params -- n )
#! One cell is temporary storage, temp@
dup return>> return-size
swap alien-stack-frame +
cell + ;
#! Two cells for temporary storage, temp@ and on x86.64,
#! small struct return value unpacking
[ return>> return-size ] [ alien-stack-frame ] bi
+ 2 cells + ;
: set-stack-frame ( n -- )
dup [ frame-required ] when* \ stack-frame set ;
@ -361,17 +359,17 @@ M: float-regs inc-reg-class
[ spill-param ] [ fastcall-param ] if
[ param-reg ] keep ;
: (flatten-int-type) ( size -- )
cell /i "void*" c-type <repetition> % ;
: (flatten-int-type) ( size -- types )
cell /i "void*" c-type <repetition> ;
GENERIC: flatten-value-type ( type -- )
GENERIC: flatten-value-type ( type -- types )
M: object flatten-value-type , ;
M: object flatten-value-type 1array ;
M: struct-type flatten-value-type ( type -- )
M: struct-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
M: long-long-type flatten-value-type ( type -- )
M: long-long-type flatten-value-type ( type -- types )
stack-size cell align (flatten-int-type) ;
: flatten-value-types ( params -- params )
@ -379,9 +377,9 @@ M: long-long-type flatten-value-type ( type -- )
[
0 [
c-type
[ parameter-align (flatten-int-type) ] keep
[ parameter-align (flatten-int-type) % ] keep
[ stack-size cell align + ] keep
flatten-value-type
flatten-value-type %
] reduce drop
] { } make ;

106
basis/compiler/tests/alien.factor
View File

@ -439,3 +439,109 @@ C-STRUCT: double-rect
[ 1.0 2.0 3.0 4.0 ]
[ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
C-STRUCT: test_struct_14
{ "double" "x1" }
{ "double" "x2" } ;
FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
[ 1.0 2.0 ] [
1.0 2.0 ffi_test_40
[ test_struct_14-x1 ] [ test_struct_14-x2 ] bi
] unit-test
: callback-10 ( -- callback )
"test_struct_14" { "double" "double" } "cdecl"
[
"test_struct_14" <c-object>
[ set-test_struct_14-x2 ] keep
[ set-test_struct_14-x1 ] keep
] alien-callback ;
: callback-10-test ( x1 x2 callback -- result )
"test_struct_14" { "double" "double" } "cdecl" alien-indirect ;
[ 1.0 2.0 ] [
1.0 2.0 callback-10 callback-10-test
[ test_struct_14-x1 ] [ test_struct_14-x2 ] bi
] unit-test
FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
[ 1 2.0 ] [
1 2.0 ffi_test_41
[ test-struct-12-a ] [ test-struct-12-x ] bi
] unit-test
: callback-11 ( -- callback )
"test-struct-12" { "int" "double" } "cdecl"
[
"test-struct-12" <c-object>
[ set-test-struct-12-x ] keep
[ set-test-struct-12-a ] keep
] alien-callback ;
: callback-11-test ( x1 x2 callback -- result )
"test-struct-12" { "int" "double" } "cdecl" alien-indirect ;
[ 1 2.0 ] [
1 2.0 callback-11 callback-11-test
[ test-struct-12-a ] [ test-struct-12-x ] bi
] unit-test
C-STRUCT: test_struct_15
{ "float" "x" }
{ "float" "y" } ;
FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ test_struct_15-x ] [ test_struct_15-y ] bi ] unit-test
: callback-12 ( -- callback )
"test_struct_15" { "float" "float" } "cdecl"
[
"test_struct_15" <c-object>
[ set-test_struct_15-y ] keep
[ set-test_struct_15-x ] keep
] alien-callback ;
: callback-12-test ( x1 x2 callback -- result )
"test_struct_15" { "float" "float" } "cdecl" alien-indirect ;
[ 1.0 2.0 ] [
1.0 2.0 callback-12 callback-12-test
[ test_struct_15-x ] [ test_struct_15-y ] bi
] unit-test
C-STRUCT: test_struct_16
{ "float" "x" }
{ "int" "a" } ;
FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ test_struct_16-x ] [ test_struct_16-a ] bi ] unit-test
: callback-13 ( -- callback )
"test_struct_16" { "float" "int" } "cdecl"
[
"test_struct_16" <c-object>
[ set-test_struct_16-a ] keep
[ set-test_struct_16-x ] keep
] alien-callback ;
: callback-13-test ( x1 x2 callback -- result )
"test_struct_16" { "float" "int" } "cdecl" alien-indirect ;
[ 1.0 2 ] [
1.0 2 callback-13 callback-13-test
[ test_struct_16-x ] [ test_struct_16-a ] bi
] unit-test
FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
[ 1.0 2.0 ] [ ffi_test_44 [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi ] unit-test
: stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
[ ] [ stack-frame-bustage 2drop ] unit-test

14
basis/cpu/architecture/architecture.factor
View File

@ -95,7 +95,7 @@ HOOK: %box-float cpu ( dst src -- )
HOOK: small-enough? cpu ( n -- ? )
! Is this structure small enough to be returned in registers?
HOOK: struct-small-enough? cpu ( size -- ? )
HOOK: struct-small-enough? cpu ( heap-size -- ? )
! Do we pass explode value structs?
HOOK: value-structs? cpu ( -- ? )
@ -109,9 +109,9 @@ HOOK: %unbox cpu ( n reg-class func -- )
HOOK: %unbox-long-long cpu ( n func -- )
HOOK: %unbox-small-struct cpu ( size -- )
HOOK: %unbox-small-struct cpu ( c-type -- )
HOOK: %unbox-large-struct cpu ( n size -- )
HOOK: %unbox-large-struct cpu ( n c-type -- )
HOOK: %box cpu ( n reg-class func -- )
@ -119,9 +119,9 @@ HOOK: %box-long-long cpu ( n func -- )
HOOK: %prepare-box-struct cpu ( size -- )
HOOK: %box-small-struct cpu ( size -- )
HOOK: %box-small-struct cpu ( c-type -- )
HOOK: %box-large-struct cpu ( n size -- )
HOOK: %box-large-struct cpu ( n c-type -- )
GENERIC: %save-param-reg ( stack reg reg-class -- )
@ -169,14 +169,14 @@ PREDICATE: small-tagged < integer v>operand small-enough? ;
[ [ nip ] prepose ] dip if ;
inline
: %unbox-struct ( n size -- )
: %unbox-struct ( n c-type -- )
[
%unbox-small-struct
] [
%unbox-large-struct
] if-small-struct ;
: %box-struct ( n size -- )
: %box-struct ( n c-type -- )
[
%box-small-struct
] [

7
basis/cpu/ppc/architecture/architecture.factor
View File

@ -195,12 +195,12 @@ M: ppc %unbox-long-long ( n func -- )
4 1 rot cell + local@ STW
] when* ;
M: ppc %unbox-large-struct ( n size -- )
M: ppc %unbox-large-struct ( n c-type -- )
! Value must be in r3
! Compute destination address
4 1 roll local@ ADDI
! Load struct size
5 LI
heap-size 5 LI
! Call the function
"to_value_struct" f %alien-invoke ;
@ -227,8 +227,9 @@ M: ppc %prepare-box-struct ( size -- )
3 1 rot f struct-return@ ADDI
3 1 0 local@ STW ;
M: ppc %box-large-struct ( n size -- )
M: ppc %box-large-struct ( n c-type -- )
#! If n = f, then we're boxing a returned struct
heap-size
[ swap struct-return@ ] keep
! Compute destination address
3 1 roll ADDI

141
basis/cpu/x86/32/32.factor
View File

@ -28,6 +28,10 @@ M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
M: x86.32 struct-small-enough? ( size -- ? )
heap-size { 1 2 4 8 } member?
os { linux netbsd solaris } member? not and ;
! On x86, parameters are never passed in registers.
M: int-regs return-reg drop EAX ;
M: int-regs param-regs drop { } ;
@ -73,62 +77,6 @@ M: object %load-param-reg 3drop ;
M: object %save-param-reg 3drop ;
M: x86.32 %prepare-unbox ( -- )
#! Move top of data stack to EAX.
EAX ESI [] MOV
ESI 4 SUB ;
: (%unbox) ( func -- )
4 [
! Push parameter
EAX PUSH
! Call the unboxer
f %alien-invoke
] with-aligned-stack ;
M: x86.32 %unbox ( n reg-class func -- )
#! The value being unboxed must already be in EAX.
#! If n is f, we're unboxing a return value about to be
#! returned by the callback. Otherwise, we're unboxing
#! a parameter to a C function about to be called.
(%unbox)
! Store the return value on the C stack
over [ store-return-reg ] [ 2drop ] if ;
M: x86.32 %unbox-long-long ( n func -- )
(%unbox)
! Store the return value on the C stack
[
dup stack@ EAX MOV
cell + stack@ EDX MOV
] when* ;
M: x86.32 %unbox-struct-2
#! Alien must be in EAX.
4 [
EAX PUSH
"alien_offset" f %alien-invoke
! Load second cell
EDX EAX 4 [+] MOV
! Load first cell
EAX EAX [] MOV
] with-aligned-stack ;
M: x86.32 %unbox-large-struct ( n size -- )
#! Alien must be in EAX.
! Compute destination address
ECX ESP roll [+] LEA
12 [
! Push struct size
PUSH
! Push destination address
ECX PUSH
! Push source address
EAX PUSH
! Copy the struct to the stack
"to_value_struct" f %alien-invoke
] with-aligned-stack ;
: box@ ( n reg-class -- stack@ )
#! Used for callbacks; we want to box the values given to
#! us by the C function caller. Computes stack location of
@ -172,8 +120,9 @@ M: x86.32 %box-long-long ( n func -- )
: struct-return@ ( size n -- n )
[ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ;
M: x86.32 %box-large-struct ( n size -- )
M: x86.32 %box-large-struct ( n c-type -- )
! Compute destination address
heap-size
[ swap struct-return@ ] keep
ECX ESP roll [+] LEA
8 [
@ -191,7 +140,46 @@ M: x86.32 %prepare-box-struct ( size -- )
! Store it as the first parameter
ESP [] EAX MOV ;
M: x86.32 %unbox-struct-1
M: x86.32 %box-small-struct ( c-type -- )
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
12 [
heap-size PUSH
EDX PUSH
EAX PUSH
"box_small_struct" f %alien-invoke
] with-aligned-stack ;
M: x86.32 %prepare-unbox ( -- )
#! Move top of data stack to EAX.
EAX ESI [] MOV
ESI 4 SUB ;
: (%unbox) ( func -- )
4 [
! Push parameter
EAX PUSH
! Call the unboxer
f %alien-invoke
] with-aligned-stack ;
M: x86.32 %unbox ( n reg-class func -- )
#! The value being unboxed must already be in EAX.
#! If n is f, we're unboxing a return value about to be
#! returned by the callback. Otherwise, we're unboxing
#! a parameter to a C function about to be called.
(%unbox)
! Store the return value on the C stack
over [ store-return-reg ] [ 2drop ] if ;
M: x86.32 %unbox-long-long ( n func -- )
(%unbox)
! Store the return value on the C stack
[
dup stack@ EAX MOV
cell + stack@ EDX MOV
] when* ;
: %unbox-struct-1 ( -- )
#! Alien must be in EAX.
4 [
EAX PUSH
@ -200,13 +188,38 @@ M: x86.32 %unbox-struct-1
EAX EAX [] MOV
] with-aligned-stack ;
M: x86.32 %box-small-struct ( size -- )
#! Box a <= 8-byte struct returned in EAX:DX. OS X only.
12 [
PUSH
EDX PUSH
: %unbox-struct-2 ( -- )
#! Alien must be in EAX.
4 [
EAX PUSH
"box_small_struct" f %alien-invoke
"alien_offset" f %alien-invoke
! Load second cell
EDX EAX 4 [+] MOV
! Load first cell
EAX EAX [] MOV
] with-aligned-stack ;
M: x86 %unbox-small-struct ( size -- )
#! Alien must be in EAX.
heap-size cell align cell /i {
{ 1 [ %unbox-struct-1 ] }
{ 2 [ %unbox-struct-2 ] }
} case ;
M: x86.32 %unbox-large-struct ( n c-type -- )
#! Alien must be in EAX.
heap-size
! Compute destination address
ECX ESP roll [+] LEA
12 [
! Push struct size
PUSH
! Push destination address
ECX PUSH
! Push source address
EAX PUSH
! Copy the struct to the stack
"to_value_struct" f %alien-invoke
] with-aligned-stack ;
M: x86.32 %prepare-alien-indirect ( -- )

128
basis/cpu/x86/64/64.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
@ -6,7 +6,7 @@ cpu.x86.allot cpu.architecture kernel kernel.private math
namespaces make sequences compiler.generator
compiler.generator.registers compiler.generator.fixup system
layouts alien alien.accessors alien.structs slots splitting
assocs ;
assocs combinators ;
IN: cpu.x86.64
M: x86.64 ds-reg R14 ;
@ -48,6 +48,44 @@ M: stack-params %load-param-reg
M: stack-params %save-param-reg
>r stack-frame* + cell + swap r> %load-param-reg ;
: with-return-regs ( quot -- )
[
V{ RDX RAX } clone int-regs set
V{ XMM1 XMM0 } clone float-regs set
call
] with-scope ; inline
! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type
stack-params "__stack_value" c-type (>>reg-class) >>
: struct-types&offset ( struct-type -- pairs )
fields>> [
[ type>> ] [ offset>> ] bi 2array
] map ;
: split-struct ( pairs -- seq )
[
[ 8 mod zero? [ t , ] when , ] assoc-each
] { } make { t } split harvest ;
: flatten-small-struct ( c-type -- seq )
struct-types&offset split-struct [
[ c-type c-type-reg-class ] map
int-regs swap member? "void*" "double" ? c-type
] map ;
: flatten-large-struct ( c-type -- seq )
heap-size cell align
cell /i "__stack_value" c-type <repetition> ;
M: struct-type flatten-value-type ( type -- seq )
dup heap-size 16 > [
flatten-large-struct
] [
flatten-small-struct
] if ;
M: x86.64 %prepare-unbox ( -- )
! First parameter is top of stack
RDI R14 [] MOV
@ -62,22 +100,26 @@ M: x86.64 %unbox ( n reg-class func -- )
M: x86.64 %unbox-long-long ( n func -- )
int-regs swap %unbox ;
M: x86.64 %unbox-struct-1 ( -- )
#! Alien must be in RDI.
"alien_offset" f %alien-invoke
! Load first cell
RAX RAX [] MOV ;
: %unbox-struct-field ( c-type i -- )
! Alien must be in RDI.
RDI swap cells [+] swap reg-class>> {
{ int-regs [ int-regs get pop swap MOV ] }
{ double-float-regs [ float-regs get pop swap MOVSD ] }
} case ;
M: x86.64 %unbox-struct-2 ( -- )
#! Alien must be in RDI.
M: x86.64 %unbox-small-struct ( c-type -- )
! Alien must be in RDI.
"alien_offset" f %alien-invoke
! Load second cell
RDX RAX cell [+] MOV
! Load first cell
RAX RAX [] MOV ;
! Move alien_offset() return value to RDI so that we don't
! clobber it.
RDI RAX MOV
[
flatten-small-struct [ %unbox-struct-field ] each-index
] with-return-regs ;
M: x86.64 %unbox-large-struct ( n size -- )
M: x86.64 %unbox-large-struct ( n c-type -- )
! Source is in RDI
heap-size
! Load destination address
RSI RSP roll [+] LEA
! Load structure size
@ -100,20 +142,33 @@ M: x86.64 %box ( n reg-class func -- )
M: x86.64 %box-long-long ( n func -- )
int-regs swap %box ;
M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ;
M: x86.64 struct-small-enough? ( size -- ? )
heap-size 2 cells <= ;
M: x86.64 %box-small-struct ( size -- )
#! Box a <= 16-byte struct returned in RAX:RDX.
RDI RAX MOV
RSI RDX MOV
RDX swap MOV
"box_small_struct" f %alien-invoke ;
: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ;
: %box-struct-field ( c-type i -- )
box-struct-field@ swap reg-class>> {
{ int-regs [ int-regs get pop MOV ] }
{ double-float-regs [ float-regs get pop MOVSD ] }
} case ;
M: x86.64 %box-small-struct ( c-type -- )
#! Box a <= 16-byte struct.
[
[ flatten-small-struct [ %box-struct-field ] each-index ]
[ RDX swap heap-size MOV ] bi
RDI 0 box-struct-field@ MOV
RSI 1 box-struct-field@ MOV
"box_small_struct" f %alien-invoke
] with-return-regs ;
: struct-return@ ( size n -- n )
[ ] [ \ stack-frame get swap - ] ?if ;
M: x86.64 %box-large-struct ( n size -- )
M: x86.64 %box-large-struct ( n c-type -- )
! Struct size is parameter 2
heap-size
RSI over MOV
! Compute destination address
swap struct-return@ RDI RSP rot [+] LEA
@ -170,32 +225,3 @@ USE: cpu.x86.intrinsics
\ alien-signed-4 small-reg-32 define-signed-getter
\ set-alien-signed-4 small-reg-32 define-setter
! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type
stack-params "__stack_value" c-type (>>reg-class) >>
: struct-types&offset ( struct-type -- pairs )
fields>> [
[ type>> ] [ offset>> ] bi 2array
] map ;
: split-struct ( pairs -- seq )
[
[ 8 mod zero? [ t , ] when , ] assoc-each
] { } make { t } split harvest ;
: flatten-large-struct ( type -- )
heap-size cell align
cell /i "__stack_value" c-type <repetition> % ;
M: struct-type flatten-value-type ( type -- seq )
dup heap-size 16 > [
flatten-large-struct
] [
struct-types&offset split-struct [
[ c-type c-type-reg-class ] map
int-regs swap member?
"void*" "double" ? c-type ,
] each
] if ;

15
basis/cpu/x86/architecture/architecture.factor
View File

@ -139,21 +139,6 @@ M: x86 small-enough? ( n -- ? )
: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
HOOK: %unbox-struct-1 cpu ( -- )
HOOK: %unbox-struct-2 cpu ( -- )
M: x86 %unbox-small-struct ( size -- )
#! Alien must be in EAX.
cell align cell /i {
{ 1 [ %unbox-struct-1 ] }
{ 2 [ %unbox-struct-2 ] }
} case ;
M: x86 struct-small-enough? ( size -- ? )
{ 1 2 4 8 } member?
os { linux netbsd solaris } member? not and ;
M: x86 %return ( -- ) 0 %unwind ;
! Alien intrinsics

2
extra/morse/tags.txt
View File

@ -1 +1 @@
example
examples

45
vm/ffi_test.c
View File

@ -280,3 +280,48 @@ int ffi_test_39(long a, long b, struct test_struct_13 s)
if(a != b) abort();
return s.x1 + s.x2 + s.x3 + s.x4 + s.x5 + s.x6;
}
struct test_struct_14 ffi_test_40(double x1, double x2)
{
struct test_struct_14 retval;
retval.x1 = x1;
retval.x2 = x2;
printf("ffi_test_40(%f,%f)\n",x1,x2);
return retval;
}
struct test_struct_12 ffi_test_41(int a, double x)
{
struct test_struct_12 retval;
retval.a = a;
retval.x = x;
printf("ffi_test_41(%d,%f)\n",a,x);
return retval;
}
struct test_struct_15 ffi_test_42(float x, float y)
{
struct test_struct_15 retval;
retval.x = x;
retval.y = y;
printf("ffi_test_42(%f,%f)\n",x,y);
return retval;
}
struct test_struct_16 ffi_test_43(float x, int a)
{
struct test_struct_16 retval;
retval.x = x;
retval.a = a;
printf("ffi_test_43(%f,%d)\n",x,a);
return retval;
}
struct test_struct_14 ffi_test_44(void)
{
struct test_struct_14 retval;
retval.x1 = 1.0;
retval.x2 = 2.0;
//printf("ffi_test_44()\n");
return retval;
}

16
vm/ffi_test.h
View File

@ -71,3 +71,19 @@ DLLEXPORT unsigned long long ffi_test_38(unsigned long long x, unsigned long lon
struct test_struct_13 { float x1, x2, x3, x4, x5, x6; };
DLLEXPORT int ffi_test_39(long a, long b, struct test_struct_13 s);
struct test_struct_14 { double x1, x2; };
DLLEXPORT struct test_struct_14 ffi_test_40(double x1, double x2);
DLLEXPORT struct test_struct_12 ffi_test_41(int a, double x);
struct test_struct_15 { float x, y; };
DLLEXPORT struct test_struct_15 ffi_test_42(float x, float y);
struct test_struct_16 { float x; int a; };
DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a);
DLLEXPORT struct test_struct_14 ffi_test_44();