compiler, cpu.x86.32: clean up FFI implementation, in particular 32-bit x86-specific backend
Slava Pestov
parent
08b683de61
commit
560b6f45cc
|
|
@ -1,18 +1,19 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.data alien.strings parser
|
||||
threads words kernel.private kernel io.encodings.utf8 eval ;
|
||||
USING: accessors alien alien.c-types alien.data alien.strings
|
||||
parser threads words kernel.private kernel io.encodings.utf8
|
||||
eval ;
|
||||
IN: alien.remote-control
|
||||
|
||||
: eval-callback ( -- callback )
|
||||
"void*" { "char*" } "cdecl"
|
||||
void* { char* } "cdecl"
|
||||
[ eval>string utf8 malloc-string ] alien-callback ;
|
||||
|
||||
: yield-callback ( -- callback )
|
||||
"void" { } "cdecl" [ yield ] alien-callback ;
|
||||
void { } "cdecl" [ yield ] alien-callback ;
|
||||
|
||||
: sleep-callback ( -- callback )
|
||||
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
|
||||
void { long } "cdecl" [ sleep ] alien-callback ;
|
||||
|
||||
: ?callback ( word -- alien )
|
||||
dup optimized? [ execute ] [ drop f ] if ; inline
|
||||
|
|
|
|||
|
|
@ -9,10 +9,10 @@ IN: compiler.alien
|
|||
|
||||
: alien-parameters ( params -- seq )
|
||||
dup parameters>>
|
||||
swap return>> large-struct? [ "void*" prefix ] when ;
|
||||
swap return>> large-struct? [ void* prefix ] when ;
|
||||
|
||||
: alien-return ( params -- ctype )
|
||||
return>> dup large-struct? [ drop "void" ] when ;
|
||||
return>> dup large-struct? [ drop void ] when ;
|
||||
|
||||
: c-type-stack-align ( type -- align )
|
||||
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
|
||||
|
|
|
|||
|
|
@ -333,25 +333,22 @@ M: reg-class reg-class-full?
|
|||
[ alloc-stack-param ] [ alloc-fastcall-param ] if
|
||||
[ param-reg ] dip ;
|
||||
|
||||
: (flatten-int-type) ( size -- seq )
|
||||
cell /i "void*" c-type <repetition> ;
|
||||
: (flatten-int-type) ( type -- seq )
|
||||
stack-size cell align cell /i void* c-type <repetition> ;
|
||||
|
||||
GENERIC: flatten-value-type ( type -- types )
|
||||
|
||||
M: object flatten-value-type 1array ;
|
||||
|
||||
M: struct-c-type flatten-value-type ( type -- types )
|
||||
stack-size cell align (flatten-int-type) ;
|
||||
|
||||
M: long-long-type flatten-value-type ( type -- types )
|
||||
stack-size cell align (flatten-int-type) ;
|
||||
M: struct-c-type flatten-value-type (flatten-int-type) ;
|
||||
M: long-long-type flatten-value-type (flatten-int-type) ;
|
||||
M: c-type-name flatten-value-type c-type flatten-value-type ;
|
||||
|
||||
: flatten-value-types ( params -- params )
|
||||
#! Convert value type structs to consecutive void*s.
|
||||
[
|
||||
0 [
|
||||
c-type
|
||||
[ parameter-align (flatten-int-type) % ] keep
|
||||
[ parameter-align cell /i void* c-type <repetition> % ] keep
|
||||
[ stack-size cell align + ] keep
|
||||
flatten-value-type %
|
||||
] reduce drop
|
||||
|
|
|
|||
|
|
@ -57,12 +57,12 @@ M:: x86.32 %dispatch ( src temp -- )
|
|||
|
||||
M: x86.32 pic-tail-reg EBX ;
|
||||
|
||||
M: x86.32 reserved-area-size 0 ;
|
||||
M: x86.32 reserved-area-size 4 cells ;
|
||||
|
||||
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
|
||||
|
||||
: push-vm-ptr ( -- )
|
||||
0 PUSH 0 rc-absolute-cell rel-vm ; ! push the vm ptr as an argument
|
||||
: save-vm-ptr ( n -- )
|
||||
stack@ 0 MOV 0 rc-absolute-cell rel-vm ;
|
||||
|
||||
M: x86.32 return-struct-in-registers? ( c-type -- ? )
|
||||
c-type
|
||||
|
|
@ -72,44 +72,34 @@ M: x86.32 return-struct-in-registers? ( c-type -- ? )
|
|||
and or ;
|
||||
|
||||
: struct-return@ ( n -- operand )
|
||||
[ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;
|
||||
[ next-stack@ ] [ stack-frame get params>> param@ ] if* ;
|
||||
|
||||
! On x86, parameters are never passed in registers.
|
||||
M: int-regs return-reg drop EAX ;
|
||||
M: int-regs param-regs drop { } ;
|
||||
M: float-regs param-regs drop { } ;
|
||||
|
||||
GENERIC: push-return-reg ( rep -- )
|
||||
GENERIC: load-return-reg ( n rep -- )
|
||||
GENERIC: store-return-reg ( n rep -- )
|
||||
GENERIC: load-return-reg ( src rep -- )
|
||||
GENERIC: store-return-reg ( dst rep -- )
|
||||
|
||||
M: int-rep push-return-reg drop EAX PUSH ;
|
||||
M: int-rep load-return-reg drop EAX swap next-stack@ MOV ;
|
||||
M: int-rep store-return-reg drop stack@ EAX MOV ;
|
||||
M: int-rep load-return-reg drop EAX swap MOV ;
|
||||
M: int-rep store-return-reg drop EAX MOV ;
|
||||
|
||||
M: float-rep push-return-reg drop ESP 4 SUB ESP [] FSTPS ;
|
||||
M: float-rep load-return-reg drop next-stack@ FLDS ;
|
||||
M: float-rep store-return-reg drop stack@ FSTPS ;
|
||||
M: float-rep load-return-reg drop FLDS ;
|
||||
M: float-rep store-return-reg drop FSTPS ;
|
||||
|
||||
M: double-rep push-return-reg drop ESP 8 SUB ESP [] FSTPL ;
|
||||
M: double-rep load-return-reg drop next-stack@ FLDL ;
|
||||
M: double-rep store-return-reg drop stack@ FSTPL ;
|
||||
|
||||
: align-sub ( n -- )
|
||||
[ align-stack ] keep - decr-stack-reg ;
|
||||
|
||||
: align-add ( n -- )
|
||||
align-stack incr-stack-reg ;
|
||||
|
||||
: with-aligned-stack ( n quot -- )
|
||||
'[ align-sub @ ] [ align-add ] bi ; inline
|
||||
M: double-rep load-return-reg drop FLDL ;
|
||||
M: double-rep store-return-reg drop FSTPL ;
|
||||
|
||||
M: x86.32 %prologue ( n -- )
|
||||
dup PUSH
|
||||
0 PUSH rc-absolute-cell rel-this
|
||||
3 cells - decr-stack-reg ;
|
||||
|
||||
M: x86.32 %load-param-reg 3drop ;
|
||||
M: x86.32 %load-param-reg
|
||||
stack-params assert=
|
||||
[ [ EAX ] dip param@ MOV ] dip
|
||||
stack@ EAX MOV ;
|
||||
|
||||
M: x86.32 %save-param-reg 3drop ;
|
||||
|
||||
|
|
@ -118,15 +108,13 @@ M: x86.32 %save-param-reg 3drop ;
|
|||
#! are boxing a return value of a C function. If n is an
|
||||
#! integer, push [ESP+n] on the stack; we are boxing a
|
||||
#! parameter being passed to a callback from C.
|
||||
over [ load-return-reg ] [ 2drop ] if ;
|
||||
over [ [ next-stack@ ] dip load-return-reg ] [ 2drop ] if ;
|
||||
|
||||
M:: x86.32 %box ( n rep func -- )
|
||||
n rep (%box)
|
||||
rep rep-size cell + [
|
||||
push-vm-ptr
|
||||
rep push-return-reg
|
||||
func f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
rep rep-size save-vm-ptr
|
||||
0 stack@ rep store-return-reg
|
||||
func f %alien-invoke ;
|
||||
|
||||
: (%box-long-long) ( n -- )
|
||||
[
|
||||
|
|
@ -136,41 +124,31 @@ M:: x86.32 %box ( n rep func -- )
|
|||
|
||||
M: x86.32 %box-long-long ( n func -- )
|
||||
[ (%box-long-long) ] dip
|
||||
12 [
|
||||
push-vm-ptr
|
||||
EDX PUSH
|
||||
EAX PUSH
|
||||
f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
8 save-vm-ptr
|
||||
4 stack@ EDX MOV
|
||||
0 stack@ EAX MOV
|
||||
f %alien-invoke ;
|
||||
|
||||
M:: x86.32 %box-large-struct ( n c-type -- )
|
||||
! Compute destination address
|
||||
EDX n struct-return@ LEA
|
||||
12 [
|
||||
push-vm-ptr
|
||||
! Push struct size
|
||||
c-type heap-size PUSH
|
||||
! Push destination address
|
||||
EDX PUSH
|
||||
! Copy the struct from the C stack
|
||||
"box_value_struct" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
8 save-vm-ptr
|
||||
4 stack@ c-type heap-size MOV
|
||||
0 stack@ EDX MOV
|
||||
"box_value_struct" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %prepare-box-struct ( -- )
|
||||
! Compute target address for value struct return
|
||||
EAX f struct-return@ LEA
|
||||
! Store it as the first parameter
|
||||
0 stack@ EAX MOV ;
|
||||
0 param@ EAX MOV ;
|
||||
|
||||
M: x86.32 %box-small-struct ( c-type -- )
|
||||
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
|
||||
16 [
|
||||
push-vm-ptr
|
||||
heap-size PUSH
|
||||
EDX PUSH
|
||||
EAX PUSH
|
||||
"box_small_struct" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
12 save-vm-ptr
|
||||
8 stack@ swap heap-size MOV
|
||||
4 stack@ EDX MOV
|
||||
0 stack@ EAX MOV
|
||||
"box_small_struct" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %prepare-unbox ( -- )
|
||||
#! Move top of data stack to EAX.
|
||||
|
|
@ -178,14 +156,9 @@ M: x86.32 %prepare-unbox ( -- )
|
|||
ESI 4 SUB ;
|
||||
|
||||
: call-unbox-func ( func -- )
|
||||
8 [
|
||||
! push the vm ptr as an argument
|
||||
push-vm-ptr
|
||||
! Push parameter
|
||||
EAX PUSH
|
||||
! Call the unboxer
|
||||
f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
4 save-vm-ptr
|
||||
0 stack@ EAX MOV
|
||||
f %alien-invoke ;
|
||||
|
||||
M: x86.32 %unbox ( n rep func -- )
|
||||
#! The value being unboxed must already be in EAX.
|
||||
|
|
@ -194,37 +167,33 @@ M: x86.32 %unbox ( n rep func -- )
|
|||
#! a parameter to a C function about to be called.
|
||||
call-unbox-func
|
||||
! Store the return value on the C stack
|
||||
over [ store-return-reg ] [ 2drop ] if ;
|
||||
over [ [ param@ ] dip store-return-reg ] [ 2drop ] if ;
|
||||
|
||||
M: x86.32 %unbox-long-long ( n func -- )
|
||||
call-unbox-func
|
||||
! Store the return value on the C stack
|
||||
[
|
||||
dup stack@ EAX MOV
|
||||
cell + stack@ EDX MOV
|
||||
dup param@ EAX MOV
|
||||
4 + param@ EDX MOV
|
||||
] when* ;
|
||||
|
||||
: %unbox-struct-1 ( -- )
|
||||
#! Alien must be in EAX.
|
||||
8 [
|
||||
push-vm-ptr
|
||||
EAX PUSH
|
||||
4 save-vm-ptr
|
||||
0 stack@ EAX MOV
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load first cell
|
||||
EAX EAX [] MOV
|
||||
] with-aligned-stack ;
|
||||
EAX EAX [] MOV ;
|
||||
|
||||
: %unbox-struct-2 ( -- )
|
||||
#! Alien must be in EAX.
|
||||
8 [
|
||||
push-vm-ptr
|
||||
EAX PUSH
|
||||
4 save-vm-ptr
|
||||
0 stack@ EAX MOV
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load second cell
|
||||
EDX EAX 4 [+] MOV
|
||||
! Load first cell
|
||||
EAX EAX [] MOV
|
||||
] with-aligned-stack ;
|
||||
EAX EAX [] MOV ;
|
||||
|
||||
M: x86 %unbox-small-struct ( size -- )
|
||||
#! Alien must be in EAX.
|
||||
|
|
@ -236,63 +205,47 @@ M: x86 %unbox-small-struct ( size -- )
|
|||
M:: x86.32 %unbox-large-struct ( n c-type -- )
|
||||
! Alien must be in EAX.
|
||||
! Compute destination address
|
||||
EDX n stack@ LEA
|
||||
16 [
|
||||
push-vm-ptr
|
||||
! Push struct size
|
||||
c-type heap-size PUSH
|
||||
! Push destination address
|
||||
EDX PUSH
|
||||
! Push source address
|
||||
EAX PUSH
|
||||
! Copy the struct to the stack
|
||||
"to_value_struct" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
EDX n param@ LEA
|
||||
12 save-vm-ptr
|
||||
8 stack@ c-type heap-size MOV
|
||||
4 stack@ EDX MOV
|
||||
0 stack@ EAX MOV
|
||||
"to_value_struct" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %nest-stacks ( -- )
|
||||
! Save current frame. See comment in vm/contexts.hpp
|
||||
EAX stack-reg stack-frame get total-size>> 3 cells - [+] LEA
|
||||
8 [
|
||||
push-vm-ptr
|
||||
EAX PUSH
|
||||
"nest_stacks" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
4 save-vm-ptr
|
||||
0 stack@ EAX MOV
|
||||
"nest_stacks" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %unnest-stacks ( -- )
|
||||
4 [
|
||||
push-vm-ptr
|
||||
"unnest_stacks" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
0 save-vm-ptr
|
||||
"unnest_stacks" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %prepare-alien-indirect ( -- )
|
||||
4 [
|
||||
push-vm-ptr
|
||||
0 save-vm-ptr
|
||||
"unbox_alien" f %alien-invoke
|
||||
] with-aligned-stack
|
||||
EBP EAX MOV ;
|
||||
|
||||
M: x86.32 %alien-indirect ( -- )
|
||||
EBP CALL ;
|
||||
|
||||
M: x86.32 %alien-callback ( quot -- )
|
||||
! Fastcall
|
||||
param-reg-1 swap %load-reference
|
||||
param-reg-2 %mov-vm-ptr
|
||||
"c_to_factor" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %callback-value ( ctype -- )
|
||||
! Align C stack
|
||||
ESP 12 SUB
|
||||
! Save top of data stack in non-volatile register
|
||||
%prepare-unbox
|
||||
EAX PUSH
|
||||
push-vm-ptr
|
||||
4 stack@ EAX MOV
|
||||
0 save-vm-ptr
|
||||
! Restore data/call/retain stacks
|
||||
"unnest_stacks" f %alien-invoke
|
||||
! Place top of data stack in EAX
|
||||
temp-reg POP
|
||||
EAX POP
|
||||
! Restore C stack
|
||||
ESP 12 ADD
|
||||
! Place former top of data stack back in EAX
|
||||
EAX 4 stack@ MOV
|
||||
! Unbox EAX
|
||||
unbox-return ;
|
||||
|
||||
|
|
@ -358,16 +311,10 @@ M: x86.32 %callback-return ( n -- )
|
|||
|
||||
M:: x86.32 %call-gc ( gc-root-count temp -- )
|
||||
temp gc-root-base param@ LEA
|
||||
12 [
|
||||
! Pass the VM ptr as the third parameter
|
||||
push-vm-ptr
|
||||
! Pass number of roots as second parameter
|
||||
gc-root-count PUSH
|
||||
! Pass pointer to start of GC roots as first parameter
|
||||
temp PUSH
|
||||
! Call GC
|
||||
"inline_gc" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
8 save-vm-ptr
|
||||
4 stack@ gc-root-count MOV
|
||||
0 stack@ temp MOV
|
||||
"inline_gc" f %alien-invoke ;
|
||||
|
||||
M: x86.32 dummy-stack-params? f ;
|
||||
|
||||
|
|
@ -375,10 +322,13 @@ M: x86.32 dummy-int-params? f ;
|
|||
|
||||
M: x86.32 dummy-fp-params? f ;
|
||||
|
||||
! Dreadful
|
||||
M: object flatten-value-type (flatten-int-type) ;
|
||||
|
||||
os windows? [
|
||||
cell "longlong" c-type (>>align)
|
||||
cell "ulonglong" c-type (>>align)
|
||||
4 "double" c-type (>>align)
|
||||
cell longlong c-type (>>align)
|
||||
cell ulonglong c-type (>>align)
|
||||
4 double c-type (>>align)
|
||||
] unless
|
||||
|
||||
check-sse
|
||||
|
|
|
|||
Loading…
Reference in New Issue