Fixes for FFI changes
Slava Pestov
parent
5b48cd2a63
commit
e6abc0be15
|
|
@ -1,199 +1,201 @@
|
||||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors arrays layouts math math.order math.parser
|
USING: accessors assocs arrays layouts math math.order math.parser
|
||||||
combinators combinators.short-circuit fry make sequences
|
combinators combinators.short-circuit fry make sequences
|
||||||
sequences.generalizations alien alien.private alien.strings
|
sequences.generalizations alien alien.private alien.strings
|
||||||
alien.c-types alien.libraries classes.struct namespaces kernel
|
alien.c-types alien.libraries classes.struct namespaces kernel
|
||||||
strings libc locals quotations words cpu.architecture
|
strings libc locals quotations words cpu.architecture
|
||||||
compiler.utilities compiler.tree compiler.cfg
|
compiler.utilities compiler.tree compiler.cfg
|
||||||
compiler.cfg.builder compiler.cfg.builder.alien.params
|
compiler.cfg.builder compiler.cfg.builder.alien.params
|
||||||
compiler.cfg.builder.alien.boxing compiler.cfg.builder.blocks
|
compiler.cfg.builder.alien.boxing compiler.cfg.builder.blocks
|
||||||
compiler.cfg.instructions compiler.cfg.stack-frame
|
compiler.cfg.instructions compiler.cfg.stack-frame
|
||||||
compiler.cfg.stacks compiler.cfg.registers compiler.cfg.hats ;
|
compiler.cfg.stacks compiler.cfg.registers compiler.cfg.hats ;
|
||||||
FROM: compiler.errors => no-such-symbol no-such-library ;
|
FROM: compiler.errors => no-such-symbol no-such-library ;
|
||||||
IN: compiler.cfg.builder.alien
|
IN: compiler.cfg.builder.alien
|
||||||
|
|
||||||
: unbox-parameters ( parameters -- vregs reps )
|
: unbox-parameters ( parameters -- vregs reps )
|
||||||
[
|
[
|
||||||
[ length iota <reversed> ] keep
|
[ length iota <reversed> ] keep
|
||||||
[ [ <ds-loc> ^^peek ] [ base-type ] bi* unbox-parameter ]
|
[ [ <ds-loc> ^^peek ] [ base-type ] bi* unbox-parameter ]
|
||||||
2 2 mnmap [ concat ] bi@
|
2 2 mnmap [ concat ] bi@
|
||||||
]
|
]
|
||||||
[ length neg ##inc-d ] bi ;
|
[ length neg ##inc-d ] bi ;
|
||||||
|
|
||||||
: prepare-struct-caller ( vregs reps return -- vregs' reps' )
|
: prepare-struct-caller ( vregs reps return -- vregs' reps' )
|
||||||
large-struct? [
|
large-struct? [
|
||||||
[ ^^prepare-struct-caller prefix ]
|
[ ^^prepare-struct-caller prefix ]
|
||||||
[ int-rep struct-return-on-stack? 2array prefix ] bi*
|
[ int-rep struct-return-on-stack? 2array prefix ] bi*
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
: caller-parameter ( vreg rep on-stack? -- insn )
|
: caller-parameter ( vreg rep on-stack? -- insn )
|
||||||
[ dup reg-class-of reg-class-full? ] dip or
|
[ dup reg-class-of reg-class-full? ] dip or
|
||||||
[ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ]
|
[ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ]
|
||||||
[ [ next-reg-param ] keep \ ##store-reg-param new-insn ]
|
[ [ next-reg-param ] keep \ ##store-reg-param new-insn ]
|
||||||
if ;
|
if ;
|
||||||
|
|
||||||
: (caller-parameters) ( vregs reps -- )
|
: (caller-parameters) ( vregs reps -- )
|
||||||
! Place ##store-stack-param instructions first. This ensures
|
! Place ##store-stack-param instructions first. This ensures
|
||||||
! that no registers are used after the ##store-reg-param
|
! that no registers are used after the ##store-reg-param
|
||||||
! instructions.
|
! instructions.
|
||||||
[ first2 caller-parameter ] 2map
|
[ first2 caller-parameter ] 2map
|
||||||
[ ##store-stack-param? ] partition [ % ] bi@ ;
|
[ ##store-stack-param? ] partition [ % ] bi@ ;
|
||||||
|
|
||||||
: caller-parameters ( params -- stack-size )
|
: caller-parameters ( params -- stack-size )
|
||||||
[ abi>> ] [ parameters>> ] [ return>> ] tri
|
[ abi>> ] [ parameters>> ] [ return>> ] tri
|
||||||
'[
|
'[
|
||||||
_ unbox-parameters
|
_ unbox-parameters
|
||||||
_ prepare-struct-caller
|
_ prepare-struct-caller
|
||||||
(caller-parameters)
|
(caller-parameters)
|
||||||
stack-params get
|
stack-params get
|
||||||
] with-param-regs ;
|
] with-param-regs ;
|
||||||
|
|
||||||
: box-return* ( node -- )
|
: box-return* ( node -- )
|
||||||
return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;
|
return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;
|
||||||
|
|
||||||
GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
|
GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
|
||||||
|
|
||||||
M: string dlsym-valid? dlsym ;
|
M: string dlsym-valid? dlsym ;
|
||||||
|
|
||||||
M: array dlsym-valid? '[ _ dlsym ] any? ;
|
M: array dlsym-valid? '[ _ dlsym ] any? ;
|
||||||
|
|
||||||
: check-dlsym ( symbols dll -- )
|
: check-dlsym ( symbols dll -- )
|
||||||
dup dll-valid? [
|
dup dll-valid? [
|
||||||
dupd dlsym-valid?
|
dupd dlsym-valid?
|
||||||
[ drop ] [ cfg get word>> no-such-symbol ] if
|
[ drop ] [ cfg get word>> no-such-symbol ] if
|
||||||
] [ dll-path cfg get word>> no-such-library drop ] if ;
|
] [ dll-path cfg get word>> no-such-library drop ] if ;
|
||||||
|
|
||||||
: decorated-symbol ( params -- symbols )
|
: decorated-symbol ( params -- symbols )
|
||||||
[ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi
|
[ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi
|
||||||
{
|
{
|
||||||
[ drop ]
|
[ drop ]
|
||||||
[ "@" glue ]
|
[ "@" glue ]
|
||||||
[ "@" glue "_" prepend ]
|
[ "@" glue "_" prepend ]
|
||||||
[ "@" glue "@" prepend ]
|
[ "@" glue "@" prepend ]
|
||||||
} 2cleave
|
} 2cleave
|
||||||
4array ;
|
4array ;
|
||||||
|
|
||||||
: alien-invoke-dlsym ( params -- symbols dll )
|
: alien-invoke-dlsym ( params -- symbols dll )
|
||||||
[ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
|
[ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ]
|
||||||
[ library>> load-library ]
|
[ library>> load-library ]
|
||||||
bi 2dup check-dlsym ;
|
bi 2dup check-dlsym ;
|
||||||
|
|
||||||
: return-size ( c-type -- n )
|
: return-size ( c-type -- n )
|
||||||
! Amount of space we reserve for a return value.
|
! Amount of space we reserve for a return value.
|
||||||
dup large-struct? [ heap-size ] [ drop 0 ] if ;
|
dup large-struct? [ heap-size ] [ drop 0 ] if ;
|
||||||
|
|
||||||
: alien-node-height ( params -- )
|
: alien-node-height ( params -- )
|
||||||
[ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
|
[ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
|
||||||
|
|
||||||
: emit-alien-block ( node quot: ( params -- ) -- )
|
: emit-alien-block ( node quot: ( params -- ) -- )
|
||||||
'[
|
'[
|
||||||
make-kill-block
|
make-kill-block
|
||||||
params>>
|
params>>
|
||||||
_ [ alien-node-height ] bi
|
_ [ alien-node-height ] bi
|
||||||
] emit-trivial-block ; inline
|
] emit-trivial-block ; inline
|
||||||
|
|
||||||
: <alien-stack-frame> ( stack-size return -- stack-frame )
|
: <alien-stack-frame> ( stack-size return -- stack-frame )
|
||||||
stack-frame new
|
stack-frame new
|
||||||
swap return-size >>return
|
swap return-size >>return
|
||||||
swap >>params
|
swap >>params
|
||||||
t >>calls-vm? ;
|
t >>calls-vm? ;
|
||||||
|
|
||||||
: emit-stack-frame ( stack-size params -- )
|
: emit-stack-frame ( stack-size params -- )
|
||||||
[ return>> ] [ abi>> ] bi
|
[ return>> ] [ abi>> ] bi
|
||||||
[ stack-cleanup ##cleanup ]
|
[ stack-cleanup ##cleanup ]
|
||||||
[ drop <alien-stack-frame> ##stack-frame ] 3bi ;
|
[ drop <alien-stack-frame> ##stack-frame ] 3bi ;
|
||||||
|
|
||||||
M: #alien-invoke emit-node
|
M: #alien-invoke emit-node
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
[ caller-parameters ]
|
[ caller-parameters ]
|
||||||
[ alien-invoke-dlsym ##alien-invoke ]
|
[ alien-invoke-dlsym ##alien-invoke ]
|
||||||
[ emit-stack-frame ]
|
[ emit-stack-frame ]
|
||||||
[ box-return* ]
|
[ box-return* ]
|
||||||
} cleave
|
} cleave
|
||||||
] emit-alien-block ;
|
] emit-alien-block ;
|
||||||
|
|
||||||
M:: #alien-indirect emit-node ( node -- )
|
M:: #alien-indirect emit-node ( node -- )
|
||||||
node [
|
node [
|
||||||
D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src
|
D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src
|
||||||
{
|
{
|
||||||
[ caller-parameters ]
|
[ caller-parameters ]
|
||||||
[ drop src ##alien-indirect ]
|
[ drop src ##alien-indirect ]
|
||||||
[ emit-stack-frame ]
|
[ emit-stack-frame ]
|
||||||
[ box-return* ]
|
[ box-return* ]
|
||||||
} cleave
|
} cleave
|
||||||
] emit-alien-block ;
|
] emit-alien-block ;
|
||||||
|
|
||||||
M: #alien-assembly emit-node
|
M: #alien-assembly emit-node
|
||||||
[
|
[
|
||||||
{
|
{
|
||||||
[ caller-parameters ]
|
[ caller-parameters ]
|
||||||
[ quot>> ##alien-assembly ]
|
[ quot>> ##alien-assembly ]
|
||||||
[ emit-stack-frame ]
|
[ emit-stack-frame ]
|
||||||
[ box-return* ]
|
[ box-return* ]
|
||||||
} cleave
|
} cleave
|
||||||
] emit-alien-block ;
|
] emit-alien-block ;
|
||||||
|
|
||||||
: callee-parameter ( rep on-stack? -- dst insn )
|
: callee-parameter ( rep on-stack? -- dst insn )
|
||||||
[ next-vreg dup ] 2dip
|
[ next-vreg dup ] 2dip
|
||||||
[ dup reg-class-of reg-class-full? ] dip or
|
[ dup reg-class-of reg-class-full? ] dip or
|
||||||
[ [ alloc-stack-param ] keep \ ##load-stack-param new-insn ]
|
[ [ alloc-stack-param ] keep \ ##load-stack-param new-insn ]
|
||||||
[ [ next-reg-param ] keep \ ##load-reg-param new-insn ]
|
[ [ next-reg-param ] keep \ ##load-reg-param new-insn ]
|
||||||
if ;
|
if ;
|
||||||
|
|
||||||
: prepare-struct-callee ( c-type -- vreg )
|
: prepare-struct-callee ( c-type -- vreg )
|
||||||
large-struct?
|
large-struct?
|
||||||
[ int-rep struct-return-on-stack? callee-parameter , ] [ f ] if ;
|
[ int-rep struct-return-on-stack? callee-parameter , ] [ f ] if ;
|
||||||
|
|
||||||
: (callee-parameters) ( params -- vregs reps )
|
: (callee-parameters) ( params -- vregs reps )
|
||||||
[ flatten-parameter-type ] map
|
[ flatten-parameter-type ] map
|
||||||
[
|
[
|
||||||
[ [ first2 callee-parameter ] 1 2 mnmap ] 1 2 mnmap
|
[ [ first2 callee-parameter ] 1 2 mnmap ] 1 2 mnmap
|
||||||
concat [ ##load-reg-param? ] partition [ % ] bi@
|
concat [ ##load-reg-param? ] partition [ % ] bi@
|
||||||
] keep ;
|
]
|
||||||
|
[ [ keys ] map ]
|
||||||
: box-parameters ( vregs reps params -- )
|
bi ;
|
||||||
##begin-callback
|
|
||||||
next-vreg next-vreg ##restore-context
|
: box-parameters ( vregs reps params -- )
|
||||||
[
|
##begin-callback
|
||||||
next-vreg next-vreg ##save-context
|
next-vreg next-vreg ##restore-context
|
||||||
box-parameter
|
[
|
||||||
1 ##inc-d D 0 ##replace
|
next-vreg next-vreg ##save-context
|
||||||
] 3each ;
|
box-parameter
|
||||||
|
1 ##inc-d D 0 ##replace
|
||||||
: callee-parameters ( params -- stack-size )
|
] 3each ;
|
||||||
[ abi>> ] [ return>> ] [ parameters>> ] tri
|
|
||||||
'[
|
: callee-parameters ( params -- stack-size )
|
||||||
_ prepare-struct-callee struct-return-area set
|
[ abi>> ] [ return>> ] [ parameters>> ] tri
|
||||||
_ [ base-type ] map [ (callee-parameters) ] [ box-parameters ] bi
|
'[
|
||||||
stack-params get
|
_ prepare-struct-callee struct-return-area set
|
||||||
struct-return-area get
|
_ [ base-type ] map [ (callee-parameters) ] [ box-parameters ] bi
|
||||||
] with-param-regs
|
stack-params get
|
||||||
struct-return-area set ;
|
struct-return-area get
|
||||||
|
] with-param-regs
|
||||||
: callback-stack-cleanup ( stack-size params -- )
|
struct-return-area set ;
|
||||||
[ nip xt>> ] [ [ return>> ] [ abi>> ] bi stack-cleanup ] 2bi
|
|
||||||
"stack-cleanup" set-word-prop ;
|
: callback-stack-cleanup ( stack-size params -- )
|
||||||
|
[ nip xt>> ] [ [ return>> ] [ abi>> ] bi stack-cleanup ] 2bi
|
||||||
M: #alien-callback emit-node
|
"stack-cleanup" set-word-prop ;
|
||||||
dup params>> xt>> dup
|
|
||||||
[
|
M: #alien-callback emit-node
|
||||||
##prologue
|
dup params>> xt>> dup
|
||||||
[
|
[
|
||||||
{
|
##prologue
|
||||||
[ callee-parameters ]
|
[
|
||||||
[ quot>> ##alien-callback ]
|
{
|
||||||
[
|
[ callee-parameters ]
|
||||||
return>> [ ##end-callback ] [
|
[ quot>> ##alien-callback ]
|
||||||
[ D 0 ^^peek ] dip
|
[
|
||||||
##end-callback
|
return>> [ ##end-callback ] [
|
||||||
base-type unbox-return
|
[ D 0 ^^peek ] dip
|
||||||
] if-void
|
##end-callback
|
||||||
]
|
base-type unbox-return
|
||||||
[ callback-stack-cleanup ]
|
] if-void
|
||||||
} cleave
|
]
|
||||||
] emit-alien-block
|
[ callback-stack-cleanup ]
|
||||||
##epilogue
|
} cleave
|
||||||
##return
|
] emit-alien-block
|
||||||
] with-cfg-builder ;
|
##epilogue
|
||||||
|
##return
|
||||||
|
] with-cfg-builder ;
|
||||||
|
|
|
||||||
|
|
@ -85,7 +85,7 @@ M: long-long-type unbox-return (unbox-return) store-return ;
|
||||||
|
|
||||||
M: struct-c-type unbox-return
|
M: struct-c-type unbox-return
|
||||||
dup return-struct-in-registers?
|
dup return-struct-in-registers?
|
||||||
[ unbox keys store-return ]
|
[ (unbox-return) store-return ]
|
||||||
[ [ struct-return-area get ] 2dip (unbox-return) implode-struct ] if ;
|
[ [ struct-return-area get ] 2dip (unbox-return) implode-struct ] if ;
|
||||||
|
|
||||||
GENERIC: flatten-parameter-type ( c-type -- reps )
|
GENERIC: flatten-parameter-type ( c-type -- reps )
|
||||||
|
|
@ -121,8 +121,7 @@ GENERIC: box-return ( c-type -- dst )
|
||||||
: load-return ( c-type -- vregs reps )
|
: load-return ( c-type -- vregs reps )
|
||||||
[
|
[
|
||||||
flatten-c-type keys
|
flatten-c-type keys
|
||||||
[ [ [ next-return-reg ] keep ^^load-reg-param ] keep ]
|
[ [ [ next-return-reg ] keep ^^load-reg-param ] map ] keep
|
||||||
1 2 mnmap
|
|
||||||
] with-return-regs ;
|
] with-return-regs ;
|
||||||
|
|
||||||
M: c-type box-return [ load-return ] keep box ;
|
M: c-type box-return [ load-return ] keep box ;
|
||||||
|
|
|
||||||
|
|
@ -7,9 +7,6 @@ cpu.x86 cpu.x86.64 compiler.cfg.builder.alien
|
||||||
compiler.cfg.builder.alien.boxing compiler.cfg.registers ;
|
compiler.cfg.builder.alien.boxing compiler.cfg.registers ;
|
||||||
IN: cpu.x86.64.unix
|
IN: cpu.x86.64.unix
|
||||||
|
|
||||||
M: int-regs param-regs
|
|
||||||
2drop { RDI RSI RDX RCX R8 R9 } ;
|
|
||||||
|
|
||||||
M: x86.64 param-regs
|
M: x86.64 param-regs
|
||||||
drop {
|
drop {
|
||||||
{ int-regs { RDI RSI RDX RCX R8 R9 } }
|
{ int-regs { RDI RSI RDX RCX R8 R9 } }
|
||||||
|
|
|
||||||
|
|
@ -88,11 +88,11 @@ MEMO: sse-version ( -- n )
|
||||||
|
|
||||||
: popcnt? ( -- ? )
|
: popcnt? ( -- ? )
|
||||||
bool { } cdecl [
|
bool { } cdecl [
|
||||||
int-regs return-reg 1 MOV
|
return-reg 1 MOV
|
||||||
CPUID
|
CPUID
|
||||||
ECX 23 BT
|
ECX 23 BT
|
||||||
int-regs return-reg dup XOR
|
return-reg dup XOR
|
||||||
int-regs return-reg SETB
|
return-reg SETB
|
||||||
] alien-assembly ;
|
] alien-assembly ;
|
||||||
|
|
||||||
: sse-string ( version -- string )
|
: sse-string ( version -- string )
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue