FFI rewrite part 2: use ##peek and ##replace instructions to access stack
Slava Pestov
parent
2912f21acc
commit
7316d41226
|
|
@ -7,7 +7,8 @@ namespaces kernel strings libc quotations cpu.architecture
|
|||
compiler.alien compiler.utilities compiler.tree compiler.cfg
|
||||
compiler.cfg.builder compiler.cfg.builder.blocks
|
||||
compiler.cfg.instructions compiler.cfg.stack-frame
|
||||
compiler.cfg.stacks ;
|
||||
compiler.cfg.stacks compiler.cfg.registers
|
||||
compiler.cfg.hats ;
|
||||
FROM: compiler.errors => no-such-symbol no-such-library ;
|
||||
IN: compiler.cfg.builder.alien
|
||||
|
||||
|
|
@ -78,9 +79,9 @@ M: reg-class reg-class-full?
|
|||
[ [ parameter-offsets ] keep ] dip 2reverse-each ; inline
|
||||
|
||||
: prepare-unbox-parameters ( parameters -- offsets types indices )
|
||||
[ parameter-offsets ] [ ] [ length iota <reversed> ] tri ;
|
||||
[ length iota <reversed> ] [ parameter-offsets ] [ ] tri ;
|
||||
|
||||
GENERIC: unbox-parameter ( n c-type -- )
|
||||
GENERIC: unbox-parameter ( src n c-type -- )
|
||||
|
||||
M: c-type unbox-parameter
|
||||
[ rep>> ] [ unboxer>> ] bi ##unbox ;
|
||||
|
|
@ -95,7 +96,10 @@ M: struct-c-type unbox-parameter
|
|||
parameters>> swap
|
||||
'[
|
||||
prepare-unbox-parameters
|
||||
[ ##pop-stack [ _ + ] dip base-type unbox-parameter ] 3each
|
||||
[
|
||||
[ <ds-loc> ^^peek ] [ _ + ] [ base-type ] tri*
|
||||
unbox-parameter
|
||||
] 3each
|
||||
]
|
||||
[ length neg ##inc-d ]
|
||||
bi ;
|
||||
|
|
@ -118,19 +122,19 @@ M: struct-c-type unbox-parameter
|
|||
\ ##load-param-reg move-parameters
|
||||
] with-param-regs ;
|
||||
|
||||
GENERIC: box-return ( c-type -- )
|
||||
GENERIC: box-return ( c-type -- dst )
|
||||
|
||||
M: c-type box-return
|
||||
[ f ] dip [ rep>> ] [ boxer>> ] bi ##box ;
|
||||
[ f ] dip [ rep>> ] [ boxer>> ] bi ^^box ;
|
||||
|
||||
M: long-long-type box-return
|
||||
[ f ] dip boxer>> ##box-long-long ;
|
||||
[ f ] dip boxer>> ^^box-long-long ;
|
||||
|
||||
M: struct-c-type box-return
|
||||
[ ##box-small-struct ] [ ##box-large-struct ] if-small-struct ;
|
||||
[ ^^box-small-struct ] [ ^^box-large-struct ] if-small-struct ;
|
||||
|
||||
: box-return* ( node -- )
|
||||
return>> [ ] [ base-type box-return ##push-stack ] if-void ;
|
||||
return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;
|
||||
|
||||
GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
|
||||
|
||||
|
|
@ -200,41 +204,37 @@ M: #alien-invoke emit-node
|
|||
|
||||
M: #alien-indirect emit-node
|
||||
[
|
||||
! Save alien at top of stack to temporary storage
|
||||
##prepare-alien-indirect
|
||||
! Unbox parameters
|
||||
dup objects>registers
|
||||
! Call alien in temporary storage
|
||||
##alien-indirect
|
||||
! Box return value
|
||||
dup ##cleanup
|
||||
box-return*
|
||||
D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr
|
||||
{
|
||||
[ drop objects>registers ]
|
||||
[ nip ##alien-indirect ]
|
||||
[ drop ##cleanup ]
|
||||
[ drop box-return* ]
|
||||
} 2cleave
|
||||
] emit-alien-node ;
|
||||
|
||||
M: #alien-assembly emit-node
|
||||
[
|
||||
! Unbox parameters
|
||||
dup objects>registers
|
||||
! Generate assembly
|
||||
dup quot>> ##alien-assembly
|
||||
! Box return value
|
||||
box-return*
|
||||
[ objects>registers ]
|
||||
[ quot>> ##alien-assembly ]
|
||||
[ box-return* ]
|
||||
tri
|
||||
] emit-alien-node ;
|
||||
|
||||
GENERIC: box-parameter ( n c-type -- )
|
||||
GENERIC: box-parameter ( n c-type -- dst )
|
||||
|
||||
M: c-type box-parameter
|
||||
[ rep>> ] [ boxer>> ] bi ##box ;
|
||||
[ rep>> ] [ boxer>> ] bi ^^box ;
|
||||
|
||||
M: long-long-type box-parameter
|
||||
boxer>> ##box-long-long ;
|
||||
boxer>> ^^box-long-long ;
|
||||
|
||||
M: struct-c-type box-parameter
|
||||
[ ##box-large-struct ] [ base-type box-parameter ] if-value-struct ;
|
||||
[ ^^box-large-struct ] [ base-type box-parameter ] if-value-struct ;
|
||||
|
||||
: box-parameters ( params -- )
|
||||
alien-parameters
|
||||
[ base-type box-parameter ##push-context-stack ] each-parameter ;
|
||||
[ base-type box-parameter next-vreg ##push-context-stack ] each-parameter ;
|
||||
|
||||
: registers>objects ( node -- )
|
||||
! Generate code for boxing input parameters in a callback.
|
||||
|
|
@ -260,7 +260,7 @@ M: struct-c-type box-parameter
|
|||
'[ _ _ do-callback ]
|
||||
>quotation ;
|
||||
|
||||
GENERIC: unbox-return ( c-type -- )
|
||||
GENERIC: unbox-return ( src c-type -- )
|
||||
|
||||
M: c-type unbox-return
|
||||
[ f ] dip [ rep>> ] [ unboxer>> ] bi ##unbox ;
|
||||
|
|
@ -280,10 +280,8 @@ M: #alien-callback emit-node
|
|||
[ wrap-callback-quot ##alien-callback ]
|
||||
[
|
||||
alien-return [ ##end-callback ] [
|
||||
##pop-context-stack
|
||||
##to-nv
|
||||
[ ^^pop-context-stack ] dip
|
||||
##end-callback
|
||||
##from-nv
|
||||
base-type unbox-return
|
||||
] if-void
|
||||
] tri
|
||||
|
|
|
|||
|
|
@ -613,55 +613,61 @@ INSN: ##stack-frame
|
|||
literal: stack-frame ;
|
||||
|
||||
INSN: ##box
|
||||
def: dst/tagged-rep
|
||||
literal: n rep boxer ;
|
||||
|
||||
INSN: ##box-long-long
|
||||
def: dst/tagged-rep
|
||||
literal: n boxer ;
|
||||
|
||||
INSN: ##box-small-struct
|
||||
def: dst/tagged-rep
|
||||
literal: c-type ;
|
||||
|
||||
INSN: ##box-large-struct
|
||||
def: dst/tagged-rep
|
||||
literal: n c-type ;
|
||||
|
||||
INSN: ##unbox
|
||||
use: src/tagged-rep
|
||||
literal: n rep unboxer ;
|
||||
|
||||
INSN: ##unbox-long-long
|
||||
use: src/tagged-rep
|
||||
literal: n unboxer ;
|
||||
|
||||
INSN: ##unbox-large-struct
|
||||
use: src/tagged-rep
|
||||
literal: n c-type ;
|
||||
|
||||
INSN: ##unbox-small-struct
|
||||
use: src/tagged-rep
|
||||
literal: c-type ;
|
||||
|
||||
INSN: ##pop-stack
|
||||
literal: n ;
|
||||
|
||||
INSN: ##pop-context-stack ;
|
||||
INSN: ##pop-context-stack
|
||||
def: dst/tagged-rep
|
||||
temp: temp/int-rep ;
|
||||
|
||||
INSN: ##prepare-box-struct ;
|
||||
|
||||
INSN: ##load-param-reg
|
||||
literal: offset reg rep ;
|
||||
|
||||
INSN: ##push-stack ;
|
||||
|
||||
INSN: ##alien-invoke
|
||||
literal: symbols dll ;
|
||||
|
||||
INSN: ##cleanup
|
||||
literal: params ;
|
||||
|
||||
INSN: ##prepare-alien-indirect ;
|
||||
|
||||
INSN: ##alien-indirect ;
|
||||
INSN: ##alien-indirect
|
||||
use: src/int-rep ;
|
||||
|
||||
INSN: ##alien-assembly
|
||||
literal: quot ;
|
||||
|
||||
INSN: ##push-context-stack ;
|
||||
INSN: ##push-context-stack
|
||||
use: src/tagged-rep
|
||||
temp: temp/int-rep ;
|
||||
|
||||
INSN: ##save-param-reg
|
||||
literal: offset reg rep ;
|
||||
|
|
@ -673,10 +679,6 @@ literal: quot ;
|
|||
|
||||
INSN: ##end-callback ;
|
||||
|
||||
INSN: ##to-nv ;
|
||||
|
||||
INSN: ##from-nv ;
|
||||
|
||||
! Control flow
|
||||
INSN: ##phi
|
||||
def: dst
|
||||
|
|
@ -812,7 +814,23 @@ UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
|
|||
UNION: clobber-insn
|
||||
##call-gc
|
||||
##unary-float-function
|
||||
##binary-float-function ;
|
||||
##binary-float-function
|
||||
##box
|
||||
##box-long-long
|
||||
##box-small-struct
|
||||
##box-large-struct
|
||||
##unbox
|
||||
##unbox-long-long
|
||||
##unbox-large-struct
|
||||
##unbox-small-struct
|
||||
##prepare-box-struct
|
||||
##load-param-reg
|
||||
##alien-invoke
|
||||
##alien-indirect
|
||||
##alien-assembly
|
||||
##save-param-reg
|
||||
##begin-callback
|
||||
##end-callback ;
|
||||
|
||||
! Instructions that have complex expansions and require that the
|
||||
! output registers are not equal to any of the input registers
|
||||
|
|
|
|||
|
|
@ -283,21 +283,16 @@ CODEGEN: ##unbox %unbox
|
|||
CODEGEN: ##unbox-long-long %unbox-long-long
|
||||
CODEGEN: ##unbox-large-struct %unbox-large-struct
|
||||
CODEGEN: ##unbox-small-struct %unbox-small-struct
|
||||
CODEGEN: ##pop-stack %pop-stack
|
||||
CODEGEN: ##pop-context-stack %pop-context-stack
|
||||
CODEGEN: ##prepare-box-struct %prepare-box-struct
|
||||
CODEGEN: ##load-param-reg %load-param-reg
|
||||
CODEGEN: ##push-stack %push-stack
|
||||
CODEGEN: ##alien-invoke %alien-invoke
|
||||
CODEGEN: ##cleanup %cleanup
|
||||
CODEGEN: ##prepare-alien-indirect %prepare-alien-indirect
|
||||
CODEGEN: ##alien-indirect %alien-indirect
|
||||
CODEGEN: ##push-context-stack %push-context-stack
|
||||
CODEGEN: ##save-param-reg %save-param-reg
|
||||
CODEGEN: ##begin-callback %begin-callback
|
||||
CODEGEN: ##alien-callback %alien-callback
|
||||
CODEGEN: ##end-callback %end-callback
|
||||
CODEGEN: ##to-nv %to-nv
|
||||
CODEGEN: ##from-nv %from-nv
|
||||
|
||||
M: ##alien-assembly generate-insn quot>> call( -- ) ;
|
||||
|
|
|
|||
|
|
@ -99,8 +99,6 @@ FUNCTION: TINY ffi_test_17 int x ;
|
|||
|
||||
{ 1 1 } [ indirect-test-1 ] must-infer-as
|
||||
|
||||
[ B{ } indirect-test-1 ] [ { "kernel-error" 3 6 B{ } } = ] must-fail-with
|
||||
|
||||
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
|
||||
|
||||
: indirect-test-1' ( ptr -- )
|
||||
|
|
|
|||
|
|
@ -553,48 +553,40 @@ HOOK: dummy-int-params? cpu ( -- ? )
|
|||
! If t, all int parameters are shadowed by dummy FP parameters
|
||||
HOOK: dummy-fp-params? cpu ( -- ? )
|
||||
|
||||
! Load a value (from the data stack in the ds register).
|
||||
! The value is then passed as a parameter to a VM to_*() function
|
||||
HOOK: %pop-stack cpu ( n -- )
|
||||
|
||||
! Store a value (to the data stack in the VM's current context)
|
||||
! The value is passed to a VM to_*() function -- used for
|
||||
! callback returns
|
||||
HOOK: %pop-context-stack cpu ( -- )
|
||||
|
||||
! Store a value (to the data stack in the ds register).
|
||||
! The value was returned from a VM from_*() function
|
||||
HOOK: %push-stack cpu ( -- )
|
||||
HOOK: %pop-context-stack cpu ( dst temp -- )
|
||||
|
||||
! Store a value (to the data stack in the VM's current context)
|
||||
! The value is returned from a VM from_*() function -- used for
|
||||
! callback parameters
|
||||
HOOK: %push-context-stack cpu ( -- )
|
||||
HOOK: %push-context-stack cpu ( src temp -- )
|
||||
|
||||
! Call a function to convert a tagged pointer returned by
|
||||
! %pop-stack or %pop-context-stack into a value that can be
|
||||
! passed to a C function, or returned from a callback
|
||||
HOOK: %unbox cpu ( n rep func -- )
|
||||
HOOK: %unbox cpu ( src n rep func -- )
|
||||
|
||||
HOOK: %unbox-long-long cpu ( n func -- )
|
||||
HOOK: %unbox-long-long cpu ( src n func -- )
|
||||
|
||||
HOOK: %unbox-small-struct cpu ( c-type -- )
|
||||
HOOK: %unbox-small-struct cpu ( src c-type -- )
|
||||
|
||||
HOOK: %unbox-large-struct cpu ( n c-type -- )
|
||||
HOOK: %unbox-large-struct cpu ( src n c-type -- )
|
||||
|
||||
! Call a function to convert a value into a tagged pointer,
|
||||
! possibly allocating a bignum, float, or alien instance,
|
||||
! which is then pushed on the data stack by %push-stack or
|
||||
! %push-context-stack
|
||||
HOOK: %box cpu ( n rep func -- )
|
||||
HOOK: %box cpu ( dst n rep func -- )
|
||||
|
||||
HOOK: %box-long-long cpu ( n func -- )
|
||||
HOOK: %box-long-long cpu ( dst n func -- )
|
||||
|
||||
HOOK: %prepare-box-struct cpu ( -- )
|
||||
|
||||
HOOK: %box-small-struct cpu ( c-type -- )
|
||||
HOOK: %box-small-struct cpu ( dst c-type -- )
|
||||
|
||||
HOOK: %box-large-struct cpu ( n c-type -- )
|
||||
HOOK: %box-large-struct cpu ( dst n c-type -- )
|
||||
|
||||
HOOK: %save-param-reg cpu ( stack reg rep -- )
|
||||
|
||||
|
|
@ -604,19 +596,13 @@ HOOK: %restore-context cpu ( temp1 temp2 -- )
|
|||
|
||||
HOOK: %save-context cpu ( temp1 temp2 -- )
|
||||
|
||||
HOOK: %prepare-var-args cpu ( -- )
|
||||
|
||||
M: object %prepare-var-args ;
|
||||
|
||||
HOOK: %alien-invoke cpu ( function library -- )
|
||||
|
||||
HOOK: %cleanup cpu ( params -- )
|
||||
|
||||
M: object %cleanup ( params -- ) drop ;
|
||||
|
||||
HOOK: %prepare-alien-indirect cpu ( -- )
|
||||
|
||||
HOOK: %alien-indirect cpu ( -- )
|
||||
HOOK: %alien-indirect cpu ( src -- )
|
||||
|
||||
HOOK: %begin-callback cpu ( -- )
|
||||
|
||||
|
|
@ -624,10 +610,6 @@ HOOK: %alien-callback cpu ( quot -- )
|
|||
|
||||
HOOK: %end-callback cpu ( -- )
|
||||
|
||||
HOOK: %to-nv cpu ( -- )
|
||||
|
||||
HOOK: %from-nv cpu ( -- )
|
||||
|
||||
HOOK: stack-cleanup cpu ( params -- n )
|
||||
|
||||
M: object stack-cleanup drop 0 ;
|
||||
|
|
|
|||
|
|
@ -151,11 +151,12 @@ M: x86.32 %load-param-reg [ swap local@ ] dip %copy ;
|
|||
#! parameter being passed to a callback from C.
|
||||
over [ [ local@ ] dip load-return-reg ] [ 2drop ] if ;
|
||||
|
||||
M:: x86.32 %box ( n rep func -- )
|
||||
M:: x86.32 %box ( dst n rep func -- )
|
||||
n rep (%box)
|
||||
rep rep-size save-vm-ptr
|
||||
0 stack@ rep store-return-reg
|
||||
func f %alien-invoke ;
|
||||
func f %alien-invoke
|
||||
dst EAX tagged-rep %copy ;
|
||||
|
||||
: (%box-long-long) ( n -- )
|
||||
[
|
||||
|
|
@ -163,19 +164,21 @@ M:: x86.32 %box ( n rep func -- )
|
|||
EAX swap cell - next-stack@ MOV
|
||||
] when* ;
|
||||
|
||||
M: x86.32 %box-long-long ( n func -- )
|
||||
[ (%box-long-long) ] dip
|
||||
M:: x86.32 %box-long-long ( dst n func -- )
|
||||
n (%box-long-long)
|
||||
8 save-vm-ptr
|
||||
4 stack@ EDX MOV
|
||||
0 stack@ EAX MOV
|
||||
f %alien-invoke ;
|
||||
func f %alien-invoke
|
||||
dst EAX tagged-rep %copy ;
|
||||
|
||||
M:: x86.32 %box-large-struct ( n c-type -- )
|
||||
M:: x86.32 %box-large-struct ( dst n c-type -- )
|
||||
EDX n struct-return@ LEA
|
||||
8 save-vm-ptr
|
||||
4 stack@ c-type heap-size MOV
|
||||
0 stack@ EDX MOV
|
||||
"from_value_struct" f %alien-invoke ;
|
||||
"from_value_struct" f %alien-invoke
|
||||
dst EAX tagged-rep %copy ;
|
||||
|
||||
M: x86.32 %prepare-box-struct ( -- )
|
||||
! Compute target address for value struct return
|
||||
|
|
@ -183,38 +186,36 @@ M: x86.32 %prepare-box-struct ( -- )
|
|||
! Store it as the first parameter
|
||||
0 local@ EAX MOV ;
|
||||
|
||||
M: x86.32 %box-small-struct ( c-type -- )
|
||||
M: x86.32 %box-small-struct ( dst c-type -- )
|
||||
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
|
||||
12 save-vm-ptr
|
||||
8 stack@ swap heap-size MOV
|
||||
4 stack@ EDX MOV
|
||||
0 stack@ EAX MOV
|
||||
"from_small_struct" f %alien-invoke ;
|
||||
"from_small_struct" f %alien-invoke
|
||||
dst EAX tagged-rep %copy ;
|
||||
|
||||
M: x86.32 %pop-stack ( n -- )
|
||||
EAX swap ds-reg reg-stack MOV ;
|
||||
M:: x86.32 %pop-context-stack ( dst temp -- )
|
||||
temp %context
|
||||
dst temp "datastack" context-field-offset [+] MOV
|
||||
dst dst [] MOV
|
||||
temp "datastack" context-field-offset [+] bootstrap-cell SUB ;
|
||||
|
||||
M: x86.32 %pop-context-stack ( -- )
|
||||
temp-reg %context
|
||||
EAX temp-reg "datastack" context-field-offset [+] MOV
|
||||
EAX EAX [] MOV
|
||||
temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
|
||||
|
||||
: call-unbox-func ( func -- )
|
||||
: call-unbox-func ( src func -- )
|
||||
EAX src tagged-rep %copy
|
||||
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.
|
||||
#! 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.
|
||||
call-unbox-func
|
||||
M:: x86.32 %unbox ( src n rep func -- )
|
||||
! 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.
|
||||
src func call-unbox-func
|
||||
! Store the return value on the C stack
|
||||
over [ [ local@ ] dip store-return-reg ] [ 2drop ] if ;
|
||||
n [ n local@ rep store-return-reg ] when ;
|
||||
|
||||
M: x86.32 %unbox-long-long ( n func -- )
|
||||
M:: x86.32 %unbox-long-long ( src n func -- )
|
||||
call-unbox-func
|
||||
! Store the return value on the C stack
|
||||
[
|
||||
|
|
@ -222,33 +223,15 @@ M: x86.32 %unbox-long-long ( n func -- )
|
|||
[ 4 + local@ EDX MOV ] bi
|
||||
] when* ;
|
||||
|
||||
: %unbox-struct-1 ( -- )
|
||||
#! Alien must be in EAX.
|
||||
4 save-vm-ptr
|
||||
0 stack@ EAX MOV
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load first cell
|
||||
EAX EAX [] MOV ;
|
||||
M: x86 %unbox-small-struct ( src size -- )
|
||||
[ "alien_offset" call-unbox-func ]
|
||||
[
|
||||
heap-size 4 > [ EDX EAX 4 [+] MOV ] when
|
||||
EAX EAX [] MOV
|
||||
] bi* ;
|
||||
|
||||
: %unbox-struct-2 ( -- )
|
||||
#! Alien must be in EAX.
|
||||
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 ;
|
||||
|
||||
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.
|
||||
M:: x86.32 %unbox-large-struct ( src n c-type -- )
|
||||
EAX src tagged-rep %copy
|
||||
! Compute destination address
|
||||
EDX n local@ LEA
|
||||
12 save-vm-ptr
|
||||
|
|
@ -257,16 +240,8 @@ M:: x86.32 %unbox-large-struct ( n c-type -- )
|
|||
0 stack@ EAX MOV
|
||||
"to_value_struct" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %prepare-alien-indirect ( -- )
|
||||
EAX ds-reg [] MOV
|
||||
ds-reg 4 SUB
|
||||
4 save-vm-ptr
|
||||
0 stack@ EAX MOV
|
||||
"pinned_alien_offset" f %alien-invoke
|
||||
EBP EAX MOV ;
|
||||
|
||||
M: x86.32 %alien-indirect ( -- )
|
||||
EBP CALL ;
|
||||
M: x86.32 %alien-indirect ( src -- )
|
||||
?spill-slot CALL ;
|
||||
|
||||
M: x86.32 %begin-callback ( -- )
|
||||
0 save-vm-ptr
|
||||
|
|
@ -283,10 +258,6 @@ M: x86.32 %end-callback ( -- )
|
|||
0 save-vm-ptr
|
||||
"end_callback" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %to-nv ( -- ) 4 stack@ EAX MOV ;
|
||||
|
||||
M: x86.32 %from-nv ( -- ) EAX 4 stack@ MOV ;
|
||||
|
||||
GENERIC: float-function-param ( stack-slot dst src -- )
|
||||
|
||||
M:: spill-slot float-function-param ( stack-slot dst src -- )
|
||||
|
|
|
|||
|
|
@ -117,16 +117,14 @@ M: x86.64 %load-param-reg [ swap param@ ] dip %copy ;
|
|||
call
|
||||
] with-scope ; inline
|
||||
|
||||
M: x86.64 %pop-stack ( n -- )
|
||||
param-reg-0 swap ds-reg reg-stack MOV ;
|
||||
M:: x86.64 %pop-context-stack ( dst temp -- )
|
||||
temp %context
|
||||
dst temp "datastack" context-field-offset [+] MOV
|
||||
dst dst [] MOV
|
||||
temp "datastack" context-field-offset [+] bootstrap-cell SUB ;
|
||||
|
||||
M: x86.64 %pop-context-stack ( -- )
|
||||
temp-reg %context
|
||||
param-reg-0 temp-reg "datastack" context-field-offset [+] MOV
|
||||
param-reg-0 param-reg-0 [] MOV
|
||||
temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
|
||||
|
||||
M:: x86.64 %unbox ( n rep func -- )
|
||||
M:: x86.64 %unbox ( src n rep func -- )
|
||||
param-reg-0 src tagged-rep %copy
|
||||
param-reg-1 %mov-vm-ptr
|
||||
! Call the unboxer
|
||||
func f %alien-invoke
|
||||
|
|
@ -136,25 +134,25 @@ M:: x86.64 %unbox ( n rep func -- )
|
|||
n [ n rep reg-class-of return-reg rep %save-param-reg ] when ;
|
||||
|
||||
: %unbox-struct-field ( rep i -- )
|
||||
! Alien must be in param-reg-0.
|
||||
R11 swap cells [+] swap reg-class-of {
|
||||
{ int-regs [ int-regs get pop swap MOV ] }
|
||||
{ float-regs [ float-regs get pop swap MOVSD ] }
|
||||
} case ;
|
||||
|
||||
M: x86.64 %unbox-small-struct ( c-type -- )
|
||||
! Alien must be in param-reg-0.
|
||||
M:: x86.64 %unbox-small-struct ( src c-type -- )
|
||||
param-reg-0 src tagged-rep %copy
|
||||
param-reg-1 %mov-vm-ptr
|
||||
"alien_offset" f %alien-invoke
|
||||
! Move alien_offset() return value to R11 so that we don't
|
||||
! clobber it.
|
||||
R11 RAX MOV
|
||||
[
|
||||
flatten-struct-type [ %unbox-struct-field ] each-index
|
||||
c-type flatten-struct-type
|
||||
[ %unbox-struct-field ] each-index
|
||||
] with-return-regs ;
|
||||
|
||||
M:: x86.64 %unbox-large-struct ( n c-type -- )
|
||||
! Source is in param-reg-0
|
||||
M:: x86.64 %unbox-large-struct ( src n c-type -- )
|
||||
param-reg-0 src tagged-rep %copy
|
||||
! Load destination address into param-reg-1
|
||||
param-reg-1 n param@ LEA
|
||||
! Load structure size into param-reg-2
|
||||
|
|
@ -169,7 +167,7 @@ M:: x86.64 %unbox-large-struct ( n c-type -- )
|
|||
[ ]
|
||||
tri %copy ;
|
||||
|
||||
M:: x86.64 %box ( n rep func -- )
|
||||
M:: x86.64 %box ( dst n rep func -- )
|
||||
n [
|
||||
n
|
||||
0 rep reg-class-of cdecl param-reg
|
||||
|
|
@ -178,7 +176,8 @@ M:: x86.64 %box ( n rep func -- )
|
|||
rep load-return-value
|
||||
] if
|
||||
rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr
|
||||
func f %alien-invoke ;
|
||||
func f %alien-invoke
|
||||
dst RAX tagged-rep %copy ;
|
||||
|
||||
: box-struct-field@ ( i -- operand ) 1 + cells param@ ;
|
||||
|
||||
|
|
@ -188,28 +187,30 @@ M:: x86.64 %box ( n rep func -- )
|
|||
{ float-regs [ float-regs get pop MOVSD ] }
|
||||
} case ;
|
||||
|
||||
M: x86.64 %box-small-struct ( c-type -- )
|
||||
M:: x86.64 %box-small-struct ( dst c-type -- )
|
||||
#! Box a <= 16-byte struct.
|
||||
[
|
||||
[ flatten-struct-type [ %box-struct-field ] each-index ]
|
||||
[ param-reg-2 swap heap-size MOV ] bi
|
||||
c-type flatten-struct-type [ %box-struct-field ] each-index
|
||||
param-reg-2 c-type heap-size MOV
|
||||
param-reg-0 0 box-struct-field@ MOV
|
||||
param-reg-1 1 box-struct-field@ MOV
|
||||
param-reg-3 %mov-vm-ptr
|
||||
"from_small_struct" f %alien-invoke
|
||||
dst RAX tagged-rep %copy
|
||||
] with-return-regs ;
|
||||
|
||||
: struct-return@ ( n -- operand )
|
||||
[ stack-frame get params>> ] unless* param@ ;
|
||||
|
||||
M: x86.64 %box-large-struct ( n c-type -- )
|
||||
M:: x86.64 %box-large-struct ( dst n c-type -- )
|
||||
! Struct size is parameter 2
|
||||
param-reg-1 swap heap-size MOV
|
||||
param-reg-1 c-type heap-size MOV
|
||||
! Compute destination address
|
||||
param-reg-0 swap struct-return@ LEA
|
||||
param-reg-0 n struct-return@ LEA
|
||||
param-reg-2 %mov-vm-ptr
|
||||
! Copy the struct from the C stack
|
||||
"from_value_struct" f %alien-invoke ;
|
||||
"from_value_struct" f %alien-invoke
|
||||
dst RAX tagged-rep %copy ;
|
||||
|
||||
M: x86.64 %prepare-box-struct ( -- )
|
||||
! Compute target address for value struct return
|
||||
|
|
@ -217,22 +218,13 @@ M: x86.64 %prepare-box-struct ( -- )
|
|||
! Store it as the first parameter
|
||||
0 param@ RAX MOV ;
|
||||
|
||||
M: x86.64 %prepare-var-args RAX RAX XOR ;
|
||||
|
||||
M: x86.64 %alien-invoke
|
||||
R11 0 MOV
|
||||
rc-absolute-cell rel-dlsym
|
||||
R11 CALL ;
|
||||
|
||||
M: x86.64 %prepare-alien-indirect ( -- )
|
||||
param-reg-0 ds-reg [] MOV
|
||||
ds-reg 8 SUB
|
||||
param-reg-1 %mov-vm-ptr
|
||||
"pinned_alien_offset" f %alien-invoke
|
||||
nv-reg RAX MOV ;
|
||||
|
||||
M: x86.64 %alien-indirect ( -- )
|
||||
nv-reg CALL ;
|
||||
M: x86.64 %alien-indirect ( src -- )
|
||||
?spill-slot CALL ;
|
||||
|
||||
M: x86.64 %begin-callback ( -- )
|
||||
param-reg-0 %mov-vm-ptr
|
||||
|
|
@ -249,10 +241,6 @@ M: x86.64 %end-callback ( -- )
|
|||
param-reg-0 %mov-vm-ptr
|
||||
"end_callback" f %alien-invoke ;
|
||||
|
||||
M: x86.64 %to-nv ( -- ) nv-reg param-reg-0 MOV ;
|
||||
|
||||
M: x86.64 %from-nv ( -- ) param-reg-0 nv-reg MOV ;
|
||||
|
||||
: float-function-param ( i src -- )
|
||||
[ float-regs cdecl param-regs nth ] dip double-rep %copy ;
|
||||
|
||||
|
|
|
|||
|
|
@ -180,9 +180,11 @@ M: object copy-memory* copy-register* ;
|
|||
M: float-rep copy-memory* drop MOVSS ;
|
||||
M: double-rep copy-memory* drop MOVSD ;
|
||||
|
||||
: ?spill-slot ( obj -- obj ) dup spill-slot? [ n>> spill@ ] when ;
|
||||
|
||||
M: x86 %copy ( dst src rep -- )
|
||||
2over eq? [ 3drop ] [
|
||||
[ [ dup spill-slot? [ n>> spill@ ] when ] bi@ ] dip
|
||||
[ [ ?spill-slot ] bi@ ] dip
|
||||
2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if
|
||||
] if ;
|
||||
|
||||
|
|
@ -502,15 +504,11 @@ M:: x86 %check-nursery-branch ( label size cc temp1 temp2 -- )
|
|||
M: x86 %alien-global ( dst symbol library -- )
|
||||
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
|
||||
|
||||
M: x86 %push-stack ( -- )
|
||||
ds-reg cell ADD
|
||||
ds-reg [] int-regs return-reg MOV ;
|
||||
|
||||
M: x86 %push-context-stack ( -- )
|
||||
temp-reg %context
|
||||
temp-reg "datastack" context-field-offset [+] bootstrap-cell ADD
|
||||
temp-reg temp-reg "datastack" context-field-offset [+] MOV
|
||||
temp-reg [] int-regs return-reg MOV ;
|
||||
M:: x86 %push-context-stack ( src temp -- )
|
||||
temp %context
|
||||
temp "datastack" context-field-offset [+] bootstrap-cell ADD
|
||||
temp temp "datastack" context-field-offset [+] MOV
|
||||
temp [] src MOV ;
|
||||
|
||||
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
|
||||
|
||||
|
|
|
|||
|
|
@ -20,9 +20,6 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
|
|||
: param-prep-quot ( params -- quot )
|
||||
parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
|
||||
|
||||
: infer-params ( params -- )
|
||||
param-prep-quot infer-quot-here ;
|
||||
|
||||
: alien-stack ( params extra -- )
|
||||
over parameters>> length + consume-d >>in-d
|
||||
dup return>> void? 0 1 ? produce-d >>out-d
|
||||
|
|
@ -62,7 +59,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
|
|||
! Set ABI
|
||||
dup library>> library-abi >>abi
|
||||
! Quotation which coerces parameters to required types
|
||||
dup infer-params
|
||||
dup param-prep-quot infer-quot-here
|
||||
! Magic #: consume exactly the number of inputs
|
||||
dup 0 alien-stack
|
||||
! Add node to IR
|
||||
|
|
@ -76,10 +73,8 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
|
|||
pop-abi
|
||||
pop-params
|
||||
pop-return
|
||||
! Quotation which coerces parameters to required types
|
||||
1 infer->r
|
||||
dup infer-params
|
||||
1 infer-r>
|
||||
! Coerce parameters to required types
|
||||
dup param-prep-quot '[ _ [ >c-ptr ] bi* ] infer-quot-here
|
||||
! Magic #: consume the function pointer, too
|
||||
dup 1 alien-stack
|
||||
! Add node to IR
|
||||
|
|
@ -95,7 +90,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
|
|||
pop-params
|
||||
pop-return
|
||||
! Quotation which coerces parameters to required types
|
||||
dup infer-params
|
||||
dup param-prep-quot infer-quot-here
|
||||
! Magic #: consume exactly the number of inputs
|
||||
dup 0 alien-stack
|
||||
! Add node to IR
|
||||
|
|
|
|||
Loading…
Reference in New Issue