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