FFI rewrite part 5: return value boxing and callback parameter boxing now uses vregs; simplify return value unboxing
Slava Pestov
parent
0c27f30475
commit
5b48cd2a63
|
|
@ -24,8 +24,6 @@ M: array c-type-align-first first c-type-align-first ;
|
|||
|
||||
M: array base-type drop void* base-type ;
|
||||
|
||||
M: array stack-size drop void* stack-size ;
|
||||
|
||||
PREDICATE: string-type < pair
|
||||
first2 [ c-string = ] [ word? ] bi* and ;
|
||||
|
||||
|
|
@ -43,8 +41,6 @@ M: string-type c-type-align-first drop void* c-type-align-first ;
|
|||
|
||||
M: string-type base-type drop void* base-type ;
|
||||
|
||||
M: string-type stack-size drop void* stack-size ;
|
||||
|
||||
M: string-type c-type-rep drop int-rep ;
|
||||
|
||||
M: string-type c-type-boxer-quot
|
||||
|
|
|
|||
|
|
@ -14,11 +14,6 @@ HELP: heap-size
|
|||
}
|
||||
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
||||
|
||||
HELP: stack-size
|
||||
{ $values { "name" "a C type name" } { "size" math:integer } }
|
||||
{ $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." }
|
||||
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
|
||||
|
||||
HELP: <c-type>
|
||||
{ $values { "c-type" c-type } }
|
||||
{ $description "Creates a prototypical C type. User code should use higher-level facilities to define C types; see " { $link "c-data" } "." } ;
|
||||
|
|
|
|||
|
|
@ -17,8 +17,7 @@ SYMBOLS:
|
|||
long ulong
|
||||
longlong ulonglong
|
||||
float double
|
||||
void* bool
|
||||
(stack-value) ;
|
||||
void* bool ;
|
||||
|
||||
SINGLETON: void
|
||||
|
||||
|
|
@ -114,10 +113,6 @@ GENERIC: heap-size ( name -- size )
|
|||
|
||||
M: abstract-c-type heap-size size>> ;
|
||||
|
||||
GENERIC: stack-size ( name -- size )
|
||||
|
||||
M: c-type stack-size size>> cell align ;
|
||||
|
||||
MIXIN: value-type
|
||||
|
||||
: c-getter ( name -- quot )
|
||||
|
|
@ -144,8 +139,7 @@ PROTOCOL: c-type-protocol
|
|||
c-type-align
|
||||
c-type-align-first
|
||||
base-type
|
||||
heap-size
|
||||
stack-size ;
|
||||
heap-size ;
|
||||
|
||||
CONSULT: c-type-protocol c-type-name
|
||||
c-type ;
|
||||
|
|
@ -448,9 +442,6 @@ M: pointer c-type
|
|||
object >>boxed-class
|
||||
\ bool define-primitive-type
|
||||
|
||||
\ void* c-type clone stack-params >>rep
|
||||
\ (stack-value) define-primitive-type
|
||||
|
||||
] with-compilation-unit
|
||||
|
||||
M: char-16-rep rep-component-type drop char ;
|
||||
|
|
|
|||
|
|
@ -168,14 +168,6 @@ M: struct-c-type c-type ;
|
|||
|
||||
M: struct-c-type base-type ;
|
||||
|
||||
M: struct-c-type stack-size
|
||||
dup value-struct? [ heap-size cell align ] [ drop cell ] if ;
|
||||
|
||||
HOOK: flatten-struct-type cpu ( type -- pairs )
|
||||
|
||||
M: object flatten-struct-type
|
||||
stack-size cell /i { int-rep f } <repetition> ;
|
||||
|
||||
: large-struct? ( type -- ? )
|
||||
{
|
||||
{ [ dup void? ] [ drop f ] }
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces accessors math.order assocs kernel sequences
|
||||
USING: namespaces accessors math math.order assocs kernel sequences
|
||||
combinators classes words cpu.architecture layouts compiler.cfg
|
||||
compiler.cfg.rpo compiler.cfg.instructions
|
||||
compiler.cfg.registers compiler.cfg.stack-frame ;
|
||||
|
|
@ -17,13 +17,15 @@ GENERIC: compute-stack-frame* ( insn -- )
|
|||
M: ##stack-frame compute-stack-frame*
|
||||
stack-frame>> request-stack-frame ;
|
||||
|
||||
M: ##call compute-stack-frame* drop frame-required? on ;
|
||||
|
||||
M: ##call-gc compute-stack-frame*
|
||||
drop
|
||||
frame-required? on
|
||||
stack-frame new t >>calls-vm? request-stack-frame ;
|
||||
|
||||
M: ##call compute-stack-frame* drop frame-required? on ;
|
||||
|
||||
M: ##alien-callback compute-stack-frame* drop frame-required? on ;
|
||||
|
||||
M: insn compute-stack-frame*
|
||||
class "frame-required?" word-prop
|
||||
[ frame-required? on ] when ;
|
||||
|
|
@ -31,10 +33,10 @@ M: insn compute-stack-frame*
|
|||
: initial-stack-frame ( -- stack-frame )
|
||||
stack-frame new cfg get spill-area-size>> >>spill-area-size ;
|
||||
|
||||
: compute-stack-frame ( insns -- )
|
||||
frame-required? off
|
||||
: compute-stack-frame ( cfg -- )
|
||||
initial-stack-frame stack-frame set
|
||||
[ instructions>> [ compute-stack-frame* ] each ] each-basic-block
|
||||
[ spill-area-size>> 0 > frame-required? set ]
|
||||
[ [ instructions>> [ compute-stack-frame* ] each ] each-basic-block ] bi
|
||||
stack-frame get dup stack-frame-size >>total-size drop ;
|
||||
|
||||
: build-stack-frame ( cfg -- cfg )
|
||||
|
|
|
|||
|
|
@ -1,100 +1,54 @@
|
|||
! 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 locals
|
||||
alien alien.private alien.strings alien.c-types alien.libraries
|
||||
classes.struct namespaces kernel strings libc quotations words
|
||||
cpu.architecture compiler.utilities compiler.tree compiler.cfg
|
||||
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.blocks compiler.cfg.instructions
|
||||
compiler.cfg.stack-frame compiler.cfg.stacks
|
||||
compiler.cfg.registers compiler.cfg.hats ;
|
||||
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
|
||||
|
||||
! output is triples with shape { vreg rep on-stack? }
|
||||
GENERIC: unbox ( src c-type -- vregs )
|
||||
|
||||
M: c-type unbox
|
||||
[ [ unboxer>> ] [ rep>> ] bi ^^unbox ] [ rep>> ] bi
|
||||
f 3array 1array ;
|
||||
|
||||
M: long-long-type unbox
|
||||
unboxer>> int-rep ^^unbox
|
||||
0 cell
|
||||
[
|
||||
int-rep f ^^load-memory-imm
|
||||
int-rep long-long-on-stack? 3array
|
||||
] bi-curry@ bi 2array ;
|
||||
|
||||
GENERIC: unbox-parameter ( src c-type -- vregs )
|
||||
|
||||
M: c-type unbox-parameter unbox ;
|
||||
|
||||
M: long-long-type unbox-parameter unbox ;
|
||||
|
||||
M:: struct-c-type unbox-parameter ( src c-type -- )
|
||||
src ^^unbox-any-c-ptr :> src
|
||||
c-type value-struct? [
|
||||
c-type flatten-struct-type
|
||||
[| pair i |
|
||||
src i cells pair first f ^^load-memory-imm
|
||||
pair first2 3array
|
||||
] map-index
|
||||
] [ { { src int-rep f } } ] if ;
|
||||
|
||||
: unbox-parameters ( parameters -- vregs )
|
||||
: unbox-parameters ( parameters -- vregs reps )
|
||||
[
|
||||
[ length iota <reversed> ] keep
|
||||
[
|
||||
[ <ds-loc> ^^peek ] [ base-type ] bi*
|
||||
unbox-parameter
|
||||
] 2map concat
|
||||
[ [ <ds-loc> ^^peek ] [ base-type ] bi* unbox-parameter ]
|
||||
2 2 mnmap [ concat ] bi@
|
||||
]
|
||||
[ length neg ##inc-d ] bi ;
|
||||
|
||||
: prepare-struct-area ( vregs return -- vregs )
|
||||
#! Return offset on C stack where to store unboxed
|
||||
#! parameters. If the C function is returning a structure,
|
||||
#! the first parameter is an implicit target area pointer,
|
||||
#! so we need to use a different offset.
|
||||
: prepare-struct-caller ( vregs reps return -- vregs' reps' )
|
||||
large-struct? [
|
||||
^^prepare-struct-area int-rep struct-return-on-stack?
|
||||
3array prefix
|
||||
[ ^^prepare-struct-caller prefix ]
|
||||
[ int-rep struct-return-on-stack? 2array prefix ] bi*
|
||||
] when ;
|
||||
|
||||
: (objects>registers) ( vregs -- )
|
||||
: 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.
|
||||
[
|
||||
first3 [ 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
|
||||
] map [ ##store-stack-param? ] partition [ % ] bi@ ;
|
||||
[ first2 caller-parameter ] 2map
|
||||
[ ##store-stack-param? ] partition [ % ] bi@ ;
|
||||
|
||||
: objects>registers ( params -- stack-size )
|
||||
: caller-parameters ( params -- stack-size )
|
||||
[ abi>> ] [ parameters>> ] [ return>> ] tri
|
||||
'[
|
||||
_ unbox-parameters
|
||||
_ prepare-struct-area
|
||||
(objects>registers)
|
||||
_ prepare-struct-caller
|
||||
(caller-parameters)
|
||||
stack-params get
|
||||
] with-param-regs ;
|
||||
|
||||
GENERIC: box-return ( c-type -- dst )
|
||||
|
||||
M: c-type box-return
|
||||
[ f ] dip [ rep>> ] [ boxer>> ] bi ^^box ;
|
||||
|
||||
M: long-long-type box-return
|
||||
[ f ] dip boxer>> ^^box-long-long ;
|
||||
|
||||
M: struct-c-type box-return
|
||||
dup return-struct-in-registers?
|
||||
[ ^^box-small-struct ] [ [ f ] dip ^^box-large-struct ] if ;
|
||||
|
||||
: box-return* ( node -- )
|
||||
return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;
|
||||
|
||||
|
|
@ -126,13 +80,8 @@ M: array dlsym-valid? '[ _ dlsym ] any? ;
|
|||
bi 2dup check-dlsym ;
|
||||
|
||||
: return-size ( c-type -- n )
|
||||
#! Amount of space we reserve for a return value.
|
||||
{
|
||||
{ [ dup void? ] [ drop 0 ] }
|
||||
{ [ dup base-type struct-c-type? not ] [ drop 0 ] }
|
||||
{ [ dup large-struct? not ] [ drop 2 cells ] }
|
||||
[ heap-size ]
|
||||
} cond ;
|
||||
! 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 ;
|
||||
|
|
@ -158,7 +107,7 @@ M: array dlsym-valid? '[ _ dlsym ] any? ;
|
|||
M: #alien-invoke emit-node
|
||||
[
|
||||
{
|
||||
[ objects>registers ]
|
||||
[ caller-parameters ]
|
||||
[ alien-invoke-dlsym ##alien-invoke ]
|
||||
[ emit-stack-frame ]
|
||||
[ box-return* ]
|
||||
|
|
@ -169,7 +118,7 @@ M:: #alien-indirect emit-node ( node -- )
|
|||
node [
|
||||
D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src
|
||||
{
|
||||
[ objects>registers ]
|
||||
[ caller-parameters ]
|
||||
[ drop src ##alien-indirect ]
|
||||
[ emit-stack-frame ]
|
||||
[ box-return* ]
|
||||
|
|
@ -179,132 +128,52 @@ M:: #alien-indirect emit-node ( node -- )
|
|||
M: #alien-assembly emit-node
|
||||
[
|
||||
{
|
||||
[ objects>registers ]
|
||||
[ caller-parameters ]
|
||||
[ quot>> ##alien-assembly ]
|
||||
[ emit-stack-frame ]
|
||||
[ box-return* ]
|
||||
} cleave
|
||||
] emit-alien-block ;
|
||||
|
||||
GENERIC: box-parameter ( n c-type -- dst )
|
||||
: 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 ;
|
||||
|
||||
M: c-type box-parameter
|
||||
[ rep>> ] [ boxer>> ] bi ^^box ;
|
||||
: prepare-struct-callee ( c-type -- vreg )
|
||||
large-struct?
|
||||
[ int-rep struct-return-on-stack? callee-parameter , ] [ f ] if ;
|
||||
|
||||
M: long-long-type box-parameter
|
||||
boxer>> ^^box-long-long ;
|
||||
|
||||
: if-value-struct ( ctype true false -- )
|
||||
[ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
|
||||
|
||||
M: struct-c-type box-parameter
|
||||
[ ^^box-large-struct ] [ base-type box-parameter ] if-value-struct ;
|
||||
|
||||
: parameter-offsets ( types -- offsets )
|
||||
0 [ stack-size + ] accumulate nip ;
|
||||
|
||||
: prepare-parameters ( parameters -- offsets types indices )
|
||||
[ length iota <reversed> ] [ parameter-offsets ] [ ] tri ;
|
||||
|
||||
: alien-parameters ( params -- seq )
|
||||
[ parameters>> ] [ return>> large-struct? ] bi
|
||||
[ struct-return-on-stack? (stack-value) void* ? prefix ] when ;
|
||||
|
||||
: box-parameters ( params -- )
|
||||
alien-parameters
|
||||
[ length ##inc-d ]
|
||||
: (callee-parameters) ( params -- vregs reps )
|
||||
[ flatten-parameter-type ] map
|
||||
[
|
||||
prepare-parameters
|
||||
[
|
||||
next-vreg next-vreg ##save-context
|
||||
base-type box-parameter swap <ds-loc> ##replace
|
||||
] 3each
|
||||
] bi ;
|
||||
[ [ first2 callee-parameter ] 1 2 mnmap ] 1 2 mnmap
|
||||
concat [ ##load-reg-param? ] partition [ % ] bi@
|
||||
] keep ;
|
||||
|
||||
:: alloc-parameter ( rep -- reg rep )
|
||||
rep dup reg-class-of reg-class-full?
|
||||
[ alloc-stack-param stack-params ] [ [ next-reg-param ] keep ] if ;
|
||||
: 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 ;
|
||||
|
||||
GENERIC: flatten-c-type ( type -- reps )
|
||||
|
||||
M: struct-c-type flatten-c-type
|
||||
flatten-struct-type [ first2 [ drop stack-params ] when ] map ;
|
||||
|
||||
M: long-long-type flatten-c-type drop { int-rep int-rep } ;
|
||||
|
||||
M: c-type flatten-c-type
|
||||
rep>> {
|
||||
{ int-rep [ { int-rep } ] }
|
||||
{ float-rep [ float-on-stack? { stack-params } { float-rep } ? ] }
|
||||
{ double-rep [
|
||||
float-on-stack?
|
||||
cell 4 = { stack-params stack-params } { stack-params } ?
|
||||
{ double-rep } ?
|
||||
] }
|
||||
{ stack-params [ { stack-params } ] }
|
||||
} case ;
|
||||
|
||||
M: object flatten-c-type base-type flatten-c-type ;
|
||||
|
||||
: flatten-c-types ( types -- reps )
|
||||
[ flatten-c-type ] map concat ;
|
||||
|
||||
: (registers>objects) ( params -- )
|
||||
[ 0 ] dip alien-parameters flatten-c-types [
|
||||
[ alloc-parameter ##save-param-reg ]
|
||||
[ rep-size cell align + ]
|
||||
2bi
|
||||
] each drop ; inline
|
||||
|
||||
: registers>objects ( params -- )
|
||||
! Generate code for boxing input parameters in a callback.
|
||||
dup abi>> [
|
||||
dup (registers>objects)
|
||||
##begin-callback
|
||||
next-vreg next-vreg ##restore-context
|
||||
box-parameters
|
||||
] with-param-regs ;
|
||||
|
||||
: callback-return-quot ( ctype -- quot )
|
||||
return>> {
|
||||
{ [ dup void? ] [ drop [ ] ] }
|
||||
{ [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
|
||||
[ c-type c-type-unboxer-quot ]
|
||||
} cond ;
|
||||
|
||||
: callback-prep-quot ( params -- quot )
|
||||
parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
|
||||
|
||||
: wrap-callback-quot ( params -- quot )
|
||||
[ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append
|
||||
yield-hook get
|
||||
'[ _ _ do-callback ]
|
||||
>quotation ;
|
||||
|
||||
GENERIC: unbox-return ( src c-type -- )
|
||||
|
||||
M: c-type unbox-return
|
||||
unbox first first2 ##store-return ;
|
||||
|
||||
M: long-long-type unbox-return
|
||||
unbox first2 [ first ] bi@ ##store-long-long-return ;
|
||||
|
||||
M: struct-c-type unbox-return
|
||||
[ ^^unbox-any-c-ptr ] dip ##store-struct-return ;
|
||||
|
||||
: emit-callback-stack-frame ( params -- )
|
||||
[ alien-parameters [ stack-size ] map-sum ] [ return>> ] bi
|
||||
<alien-stack-frame> ##stack-frame ;
|
||||
|
||||
: stack-args-size ( params -- n )
|
||||
dup abi>> [
|
||||
alien-parameters flatten-c-types
|
||||
[ alloc-parameter 2drop ] each
|
||||
: 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
|
||||
] with-param-regs ;
|
||||
struct-return-area get
|
||||
] with-param-regs
|
||||
struct-return-area set ;
|
||||
|
||||
: callback-stack-cleanup ( params -- )
|
||||
[ xt>> ] [ [ stack-args-size ] [ return>> ] [ abi>> ] tri stack-cleanup ] bi
|
||||
: callback-stack-cleanup ( stack-size params -- )
|
||||
[ nip xt>> ] [ [ return>> ] [ abi>> ] bi stack-cleanup ] 2bi
|
||||
"stack-cleanup" set-word-prop ;
|
||||
|
||||
M: #alien-callback emit-node
|
||||
|
|
@ -313,21 +182,16 @@ M: #alien-callback emit-node
|
|||
##prologue
|
||||
[
|
||||
{
|
||||
[ registers>objects ]
|
||||
[ emit-callback-stack-frame ]
|
||||
[ callback-stack-cleanup ]
|
||||
[ wrap-callback-quot ##alien-callback ]
|
||||
[ callee-parameters ]
|
||||
[ quot>> ##alien-callback ]
|
||||
[
|
||||
return>> {
|
||||
{ [ dup void? ] [ drop ##end-callback ] }
|
||||
{ [ dup large-struct? ] [ drop ##end-callback ] }
|
||||
[
|
||||
[ D 0 ^^peek ] dip
|
||||
##end-callback
|
||||
base-type unbox-return
|
||||
]
|
||||
} cond
|
||||
return>> [ ##end-callback ] [
|
||||
[ D 0 ^^peek ] dip
|
||||
##end-callback
|
||||
base-type unbox-return
|
||||
] if-void
|
||||
]
|
||||
[ callback-stack-cleanup ]
|
||||
} cleave
|
||||
] emit-alien-block
|
||||
##epilogue
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,137 @@
|
|||
! Copyright (C) 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types arrays assocs classes.struct fry
|
||||
kernel layouts locals math namespaces sequences
|
||||
sequences.generalizations system
|
||||
compiler.cfg.builder.alien.params compiler.cfg.hats
|
||||
compiler.cfg.instructions cpu.architecture ;
|
||||
IN: compiler.cfg.builder.alien.boxing
|
||||
|
||||
SYMBOL: struct-return-area
|
||||
|
||||
! pairs have shape { rep on-stack? }
|
||||
GENERIC: flatten-c-type ( c-type -- pairs )
|
||||
|
||||
M: c-type flatten-c-type
|
||||
rep>> f 2array 1array ;
|
||||
|
||||
M: long-long-type flatten-c-type
|
||||
drop 2 [ int-rep long-long-on-stack? 2array ] replicate ;
|
||||
|
||||
HOOK: flatten-struct-type cpu ( type -- pairs )
|
||||
|
||||
M: object flatten-struct-type
|
||||
heap-size cell align cell /i { int-rep f } <repetition> ;
|
||||
|
||||
M: struct-c-type flatten-c-type
|
||||
flatten-struct-type ;
|
||||
|
||||
: stack-size ( c-type -- n )
|
||||
base-type flatten-c-type keys 0 [ rep-size + ] reduce ;
|
||||
|
||||
: component-offsets ( reps -- offsets )
|
||||
0 [ rep-size + ] accumulate nip ;
|
||||
|
||||
:: explode-struct ( src c-type -- vregs reps )
|
||||
c-type flatten-struct-type :> reps
|
||||
reps keys dup component-offsets
|
||||
[| rep offset | src offset rep f ^^load-memory-imm ] 2map
|
||||
reps ;
|
||||
|
||||
:: implode-struct ( src vregs reps -- )
|
||||
vregs reps dup component-offsets
|
||||
[| vreg rep offset | vreg src offset rep f ##store-memory-imm ] 3each ;
|
||||
|
||||
GENERIC: unbox ( src c-type -- vregs reps )
|
||||
|
||||
M: c-type unbox
|
||||
[ unboxer>> ] [ rep>> ] bi
|
||||
[ ^^unbox 1array ] [ nip f 2array 1array ] 2bi ;
|
||||
|
||||
M: long-long-type unbox
|
||||
unboxer>> int-rep ^^unbox
|
||||
0 cell [ int-rep f ^^load-memory-imm ] bi-curry@ bi 2array
|
||||
int-rep long-long-on-stack? 2array dup 2array ;
|
||||
|
||||
M: struct-c-type unbox ( src c-type -- vregs )
|
||||
[ ^^unbox-any-c-ptr ] dip explode-struct ;
|
||||
|
||||
: frob-struct ( c-type -- c-type )
|
||||
dup value-struct? [ drop void* base-type ] unless ;
|
||||
|
||||
GENERIC: unbox-parameter ( src c-type -- vregs reps )
|
||||
|
||||
M: c-type unbox-parameter unbox ;
|
||||
|
||||
M: long-long-type unbox-parameter unbox ;
|
||||
|
||||
M: struct-c-type unbox-parameter frob-struct unbox ;
|
||||
|
||||
GENERIC: unbox-return ( src c-type -- )
|
||||
|
||||
: store-return ( vregs reps -- )
|
||||
[
|
||||
[ [ next-return-reg ] keep ##store-reg-param ] 2each
|
||||
] with-return-regs ;
|
||||
|
||||
: (unbox-return) ( src c-type -- vregs reps )
|
||||
! Don't care about on-stack? flag when looking at return
|
||||
! values.
|
||||
unbox keys ;
|
||||
|
||||
M: c-type unbox-return (unbox-return) store-return ;
|
||||
|
||||
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 ]
|
||||
[ [ struct-return-area get ] 2dip (unbox-return) implode-struct ] if ;
|
||||
|
||||
GENERIC: flatten-parameter-type ( c-type -- reps )
|
||||
|
||||
M: c-type flatten-parameter-type flatten-c-type ;
|
||||
|
||||
M: long-long-type flatten-parameter-type flatten-c-type ;
|
||||
|
||||
M: struct-c-type flatten-parameter-type frob-struct flatten-c-type ;
|
||||
|
||||
GENERIC: box ( vregs reps c-type -- dst )
|
||||
|
||||
M: c-type box
|
||||
[ first ] [ drop ] [ [ boxer>> ] [ rep>> ] bi ] tri* ^^box ;
|
||||
|
||||
M: long-long-type box
|
||||
[ first2 ] [ drop ] [ boxer>> ] tri* ^^box-long-long ;
|
||||
|
||||
M: struct-c-type box
|
||||
'[ _ heap-size ^^allot-byte-array dup ^^unbox-byte-array ] 2dip
|
||||
implode-struct ;
|
||||
|
||||
GENERIC: box-parameter ( vregs reps c-type -- dst )
|
||||
|
||||
M: c-type box-parameter box ;
|
||||
|
||||
M: long-long-type box-parameter box ;
|
||||
|
||||
M: struct-c-type box-parameter frob-struct box ;
|
||||
|
||||
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
|
||||
] with-return-regs ;
|
||||
|
||||
M: c-type box-return [ load-return ] keep box ;
|
||||
|
||||
M: long-long-type box-return [ load-return ] keep box ;
|
||||
|
||||
M: struct-c-type box-return
|
||||
[
|
||||
dup return-struct-in-registers?
|
||||
[ load-return ]
|
||||
[ [ ^^prepare-struct-caller ] dip explode-struct keys ] if
|
||||
] keep box ;
|
||||
|
|
@ -1,9 +1,11 @@
|
|||
! Copyright (C) 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: cpu.architecture fry kernel layouts math math.order
|
||||
namespaces sequences vectors ;
|
||||
namespaces sequences vectors assocs ;
|
||||
IN: compiler.cfg.builder.alien.params
|
||||
|
||||
SYMBOL: stack-params
|
||||
|
||||
: alloc-stack-param ( rep -- n )
|
||||
stack-params get
|
||||
[ rep-size cell align stack-params +@ ] dip ;
|
||||
|
|
@ -23,27 +25,29 @@ IN: compiler.cfg.builder.alien.params
|
|||
GENERIC: next-reg-param ( rep -- reg )
|
||||
|
||||
M: int-rep next-reg-param
|
||||
[ ?dummy-stack-params ] [ ?dummy-fp-params ] bi int-regs get pop ;
|
||||
[ ?dummy-stack-params ] [ ?dummy-fp-params ] bi
|
||||
int-regs get pop ;
|
||||
|
||||
M: float-rep next-reg-param
|
||||
[ ?dummy-stack-params ] [ ?dummy-int-params ] bi float-regs get pop ;
|
||||
[ ?dummy-stack-params ] [ ?dummy-int-params ] bi
|
||||
float-regs get pop ;
|
||||
|
||||
M: double-rep next-reg-param
|
||||
[ ?dummy-stack-params ] [ ?dummy-int-params ] bi float-regs get pop ;
|
||||
[ ?dummy-stack-params ] [ ?dummy-int-params ] bi
|
||||
float-regs get pop ;
|
||||
|
||||
GENERIC: reg-class-full? ( reg-class -- ? )
|
||||
|
||||
M: stack-params reg-class-full? drop t ;
|
||||
|
||||
M: reg-class reg-class-full? get empty? ;
|
||||
: reg-class-full? ( reg-class -- ? ) get empty? ;
|
||||
|
||||
: init-reg-class ( abi reg-class -- )
|
||||
[ swap param-regs <reversed> >vector ] keep set ;
|
||||
[ swap param-regs at <reversed> >vector ] keep set ;
|
||||
|
||||
: init-regs ( regs -- )
|
||||
[ <reversed> >vector swap set ] assoc-each ;
|
||||
|
||||
: with-param-regs ( abi quot -- )
|
||||
'[
|
||||
[ int-regs init-reg-class ]
|
||||
[ float-regs init-reg-class ] bi
|
||||
0 stack-params set
|
||||
@
|
||||
] with-scope ; inline
|
||||
'[ param-regs init-regs 0 stack-params set @ ] with-scope ; inline
|
||||
|
||||
: next-return-reg ( rep -- reg ) reg-class-of get pop ;
|
||||
|
||||
: with-return-regs ( quot -- )
|
||||
'[ return-regs init-regs @ ] with-scope ; inline
|
||||
|
|
|
|||
|
|
@ -641,35 +641,30 @@ INSN: ##store-stack-param
|
|||
use: src
|
||||
literal: n rep ;
|
||||
|
||||
INSN: ##store-return
|
||||
use: src
|
||||
literal: rep ;
|
||||
INSN: ##load-reg-param
|
||||
def: dst
|
||||
literal: reg rep ;
|
||||
|
||||
INSN: ##store-struct-return
|
||||
use: src/int-rep
|
||||
literal: c-type ;
|
||||
INSN: ##load-stack-param
|
||||
def: dst
|
||||
literal: n rep ;
|
||||
|
||||
INSN: ##store-long-long-return
|
||||
use: src1/int-rep src2/int-rep ;
|
||||
|
||||
INSN: ##prepare-struct-area
|
||||
INSN: ##prepare-struct-caller
|
||||
def: dst/int-rep ;
|
||||
|
||||
INSN: ##box
|
||||
def: dst/tagged-rep
|
||||
literal: n rep boxer ;
|
||||
use: src
|
||||
literal: boxer rep ;
|
||||
|
||||
INSN: ##box-long-long
|
||||
def: dst/tagged-rep
|
||||
literal: n boxer ;
|
||||
use: src1/int-rep src2/int-rep
|
||||
literal: boxer ;
|
||||
|
||||
INSN: ##box-small-struct
|
||||
INSN: ##allot-byte-array
|
||||
def: dst/tagged-rep
|
||||
literal: c-type ;
|
||||
|
||||
INSN: ##box-large-struct
|
||||
def: dst/tagged-rep
|
||||
literal: n c-type ;
|
||||
literal: size ;
|
||||
|
||||
INSN: ##alien-invoke
|
||||
literal: symbols dll ;
|
||||
|
|
@ -683,9 +678,6 @@ use: src/int-rep ;
|
|||
INSN: ##alien-assembly
|
||||
literal: quot ;
|
||||
|
||||
INSN: ##save-param-reg
|
||||
literal: offset reg rep ;
|
||||
|
||||
INSN: ##begin-callback ;
|
||||
|
||||
INSN: ##alien-callback
|
||||
|
|
@ -849,27 +841,31 @@ UNION: conditional-branch-insn
|
|||
UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
|
||||
UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
|
||||
|
||||
! Instructions that clobber registers
|
||||
UNION: clobber-insn
|
||||
##call-gc
|
||||
##unary-float-function
|
||||
##binary-float-function
|
||||
##box
|
||||
##box-long-long
|
||||
##box-small-struct
|
||||
##box-large-struct
|
||||
##unbox
|
||||
! Instructions that clobber registers. They receive inputs and
|
||||
! produce outputs in spill slots.
|
||||
UNION: hairy-clobber-insn
|
||||
##load-reg-param
|
||||
##store-reg-param
|
||||
##store-return
|
||||
##store-struct-return
|
||||
##store-long-long-return
|
||||
##call-gc
|
||||
##alien-invoke
|
||||
##alien-indirect
|
||||
##alien-assembly
|
||||
##save-param-reg
|
||||
##begin-callback
|
||||
##end-callback ;
|
||||
|
||||
! Instructions that clobber registers but are allowed to produce
|
||||
! outputs in registers. Inputs are in spill slots, except for
|
||||
! inputs coalesced with the output, in which case that input
|
||||
! will be in a register.
|
||||
UNION: clobber-insn
|
||||
hairy-clobber-insn
|
||||
##unary-float-function
|
||||
##binary-float-function
|
||||
##unbox
|
||||
##box
|
||||
##box-long-long
|
||||
##allot-byte-array ;
|
||||
|
||||
! Instructions that have complex expansions and require that the
|
||||
! output registers are not equal to any of the input registers
|
||||
UNION: def-is-use-insn
|
||||
|
|
|
|||
|
|
@ -36,31 +36,39 @@ IN: compiler.cfg.linear-scan.allocation
|
|||
[ drop assign-blocked-register ]
|
||||
} cond ;
|
||||
|
||||
: spill-at-sync-point ( n live-interval -- ? )
|
||||
! If the live interval has a definition at 'n', don't spill
|
||||
2dup find-use
|
||||
{ [ ] [ def-rep>> ] } 1&&
|
||||
[ 2drop t ] [ swap spill f ] if ;
|
||||
: spill-at-sync-point? ( sync-point live-interval -- ? )
|
||||
! If the live interval has a definition at a keep-dst?
|
||||
! sync-point, don't spill.
|
||||
{
|
||||
[ drop keep-dst?>> not ]
|
||||
[ [ n>> ] dip find-use dup [ def-rep>> ] when not ]
|
||||
} 2|| ;
|
||||
|
||||
: handle-sync-point ( n -- )
|
||||
: spill-at-sync-point ( sync-point live-interval -- ? )
|
||||
2dup spill-at-sync-point?
|
||||
[ swap n>> spill f ] [ 2drop t ] if ;
|
||||
|
||||
GENERIC: handle-progress* ( obj -- )
|
||||
|
||||
M: live-interval handle-progress* drop ;
|
||||
|
||||
M: sync-point handle-progress*
|
||||
active-intervals get values
|
||||
[ [ spill-at-sync-point ] with filter! drop ] with each ;
|
||||
|
||||
:: handle-progress ( n sync? -- )
|
||||
n {
|
||||
[ progress set ]
|
||||
[ deactivate-intervals ]
|
||||
[ sync? [ handle-sync-point ] [ drop ] if ]
|
||||
[ activate-intervals ]
|
||||
} cleave ;
|
||||
:: handle-progress ( n obj -- )
|
||||
n progress set
|
||||
n deactivate-intervals
|
||||
obj handle-progress*
|
||||
n activate-intervals ;
|
||||
|
||||
GENERIC: handle ( obj -- )
|
||||
|
||||
M: live-interval handle ( live-interval -- )
|
||||
[ start>> f handle-progress ] [ assign-register ] bi ;
|
||||
[ [ start>> ] keep handle-progress ] [ assign-register ] bi ;
|
||||
|
||||
M: sync-point handle ( sync-point -- )
|
||||
n>> t handle-progress ;
|
||||
[ n>> ] keep handle-progress ;
|
||||
|
||||
: smallest-heap ( heap1 heap2 -- heap )
|
||||
! If heap1 and heap2 have the same key, favors heap1.
|
||||
|
|
|
|||
|
|
@ -134,7 +134,7 @@ M: vreg-insn compute-live-intervals* ( insn -- )
|
|||
] if ;
|
||||
|
||||
! A location where all registers have to be spilled
|
||||
TUPLE: sync-point n ;
|
||||
TUPLE: sync-point n keep-dst? ;
|
||||
|
||||
C: <sync-point> sync-point
|
||||
|
||||
|
|
@ -143,8 +143,11 @@ SYMBOL: sync-points
|
|||
|
||||
GENERIC: compute-sync-points* ( insn -- )
|
||||
|
||||
M: hairy-clobber-insn compute-sync-points*
|
||||
insn#>> f <sync-point> sync-points get push ;
|
||||
|
||||
M: clobber-insn compute-sync-points*
|
||||
insn#>> <sync-point> sync-points get push ;
|
||||
insn#>> t <sync-point> sync-points get push ;
|
||||
|
||||
M: insn compute-sync-points* drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math math.order namespaces accessors kernel layouts
|
||||
combinators combinators.smart assocs sequences cpu.architecture
|
||||
combinators assocs sequences cpu.architecture
|
||||
words compiler.cfg.instructions ;
|
||||
IN: compiler.cfg.stack-frame
|
||||
|
||||
|
|
@ -13,16 +13,14 @@ TUPLE: stack-frame
|
|||
{ calls-vm? boolean } ;
|
||||
|
||||
! Stack frame utilities
|
||||
: param-base ( -- n )
|
||||
stack-frame get [ params>> ] [ return>> ] bi + ;
|
||||
: return-offset ( -- offset )
|
||||
stack-frame get params>> ;
|
||||
|
||||
: spill-offset ( n -- offset )
|
||||
param-base + ;
|
||||
stack-frame get [ params>> ] [ return>> ] bi + + ;
|
||||
|
||||
: (stack-frame-size) ( stack-frame -- n )
|
||||
[
|
||||
[ params>> ] [ return>> ] [ spill-area-size>> ] tri
|
||||
] sum-outputs ;
|
||||
[ params>> ] [ return>> ] [ spill-area-size>> ] tri + + ;
|
||||
|
||||
: max-stack-frame ( frame1 frame2 -- frame3 )
|
||||
[ stack-frame new ] 2dip
|
||||
|
|
|
|||
|
|
@ -287,15 +287,12 @@ CONDITIONAL: ##fixnum-mul %fixnum-mul
|
|||
CODEGEN: ##unbox %unbox
|
||||
CODEGEN: ##store-reg-param %store-reg-param
|
||||
CODEGEN: ##store-stack-param %store-stack-param
|
||||
CODEGEN: ##store-return %store-return
|
||||
CODEGEN: ##store-struct-return %store-struct-return
|
||||
CODEGEN: ##store-long-long-return %store-long-long-return
|
||||
CODEGEN: ##prepare-struct-area %prepare-struct-area
|
||||
CODEGEN: ##load-reg-param %load-reg-param
|
||||
CODEGEN: ##load-stack-param %load-stack-param
|
||||
CODEGEN: ##prepare-struct-caller %prepare-struct-caller
|
||||
CODEGEN: ##box %box
|
||||
CODEGEN: ##box-long-long %box-long-long
|
||||
CODEGEN: ##box-large-struct %box-large-struct
|
||||
CODEGEN: ##box-small-struct %box-small-struct
|
||||
CODEGEN: ##save-param-reg %save-param-reg
|
||||
CODEGEN: ##allot-byte-array %allot-byte-array
|
||||
CODEGEN: ##alien-invoke %alien-invoke
|
||||
CODEGEN: ##cleanup %cleanup
|
||||
CODEGEN: ##alien-indirect %alien-indirect
|
||||
|
|
|
|||
|
|
@ -150,9 +150,6 @@ SINGLETONS: int-regs float-regs ;
|
|||
UNION: reg-class int-regs float-regs ;
|
||||
CONSTANT: reg-classes { int-regs float-regs }
|
||||
|
||||
! A pseudo-register class for parameters spilled on the stack
|
||||
SINGLETON: stack-params
|
||||
|
||||
! On x86, vectors and floats are stored in the same register bank
|
||||
! On PowerPC they are distinct
|
||||
HOOK: vector-regs cpu ( -- reg-class )
|
||||
|
|
@ -165,7 +162,6 @@ M: float-rep reg-class-of drop float-regs ;
|
|||
M: double-rep reg-class-of drop float-regs ;
|
||||
M: vector-rep reg-class-of drop vector-regs ;
|
||||
M: scalar-rep reg-class-of drop vector-regs ;
|
||||
M: stack-params reg-class-of drop stack-params ;
|
||||
|
||||
GENERIC: rep-size ( rep -- n ) foldable
|
||||
|
||||
|
|
@ -173,7 +169,6 @@ M: tagged-rep rep-size drop cell ;
|
|||
M: int-rep rep-size drop cell ;
|
||||
M: float-rep rep-size drop 4 ;
|
||||
M: double-rep rep-size drop 8 ;
|
||||
M: stack-params rep-size drop cell ;
|
||||
M: vector-rep rep-size drop 16 ;
|
||||
M: char-scalar-rep rep-size drop 1 ;
|
||||
M: uchar-scalar-rep rep-size drop 1 ;
|
||||
|
|
@ -507,22 +502,6 @@ HOOK: %reload cpu ( dst rep src -- )
|
|||
|
||||
HOOK: %loop-entry cpu ( -- )
|
||||
|
||||
! FFI stuff
|
||||
|
||||
! Return values of this class go here
|
||||
GENERIC: return-reg ( reg-class -- reg )
|
||||
|
||||
! Sequence of registers used for parameter passing in class
|
||||
GENERIC# param-regs 1 ( reg-class abi -- regs )
|
||||
|
||||
M: stack-params param-regs 2drop f ;
|
||||
|
||||
GENERIC# param-reg 1 ( n reg-class abi -- reg )
|
||||
|
||||
M: reg-class param-reg param-regs nth ;
|
||||
|
||||
M: stack-params param-reg 2drop ;
|
||||
|
||||
! Does this architecture support %load-float, %load-double,
|
||||
! and %load-vector?
|
||||
HOOK: fused-unboxing? cpu ( -- ? )
|
||||
|
|
@ -552,6 +531,14 @@ M: object immediate-comparand? ( n -- ? )
|
|||
: immediate-shift-count? ( n -- ? )
|
||||
0 cell-bits 1 - between? ;
|
||||
|
||||
! FFI stuff
|
||||
|
||||
! Return values of this class go here
|
||||
HOOK: return-regs cpu ( -- regs )
|
||||
|
||||
! Registers used for parameter passing
|
||||
HOOK: param-regs cpu ( abi -- regs )
|
||||
|
||||
! Is this structure small enough to be returned in registers?
|
||||
HOOK: return-struct-in-registers? cpu ( c-type -- ? )
|
||||
|
||||
|
|
@ -584,26 +571,16 @@ HOOK: %store-reg-param cpu ( src reg rep -- )
|
|||
|
||||
HOOK: %store-stack-param cpu ( src n rep -- )
|
||||
|
||||
HOOK: %store-return cpu ( src rep -- )
|
||||
|
||||
HOOK: %store-struct-return cpu ( src reps -- )
|
||||
|
||||
HOOK: %store-long-long-return cpu ( src1 src2 -- )
|
||||
|
||||
HOOK: %prepare-struct-area cpu ( dst -- )
|
||||
HOOK: %prepare-struct-caller cpu ( dst -- )
|
||||
|
||||
! 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
|
||||
HOOK: %box cpu ( dst n rep func -- )
|
||||
HOOK: %box cpu ( dst src func rep -- )
|
||||
|
||||
HOOK: %box-long-long cpu ( dst n func -- )
|
||||
HOOK: %box-long-long cpu ( dst src1 src2 func -- )
|
||||
|
||||
HOOK: %box-small-struct cpu ( dst c-type -- )
|
||||
|
||||
HOOK: %box-large-struct cpu ( dst n c-type -- )
|
||||
|
||||
HOOK: %save-param-reg cpu ( stack reg rep -- )
|
||||
HOOK: %allot-byte-array cpu ( dst size -- )
|
||||
|
||||
HOOK: %restore-context cpu ( temp1 temp2 -- )
|
||||
|
||||
|
|
@ -617,6 +594,10 @@ M: object %cleanup ( n -- ) drop ;
|
|||
|
||||
HOOK: %alien-indirect cpu ( src -- )
|
||||
|
||||
HOOK: %load-reg-param cpu ( dst reg rep -- )
|
||||
|
||||
HOOK: %load-stack-param cpu ( dst n rep -- )
|
||||
|
||||
HOOK: %begin-callback cpu ( -- )
|
||||
|
||||
HOOK: %alien-callback cpu ( quot -- )
|
||||
|
|
|
|||
|
|
@ -13,7 +13,11 @@ M: linux reserved-area-size 2 cells ;
|
|||
|
||||
M: linux lr-save 1 cells ;
|
||||
|
||||
M: float-regs param-regs 2drop { 1 2 3 4 5 6 7 8 } ;
|
||||
M: ppc param-regs
|
||||
drop {
|
||||
{ int-regs { 3 4 5 6 7 8 9 10 } }
|
||||
{ float-regs { 1 2 3 4 5 6 7 8 } }
|
||||
} ;
|
||||
|
||||
M: ppc value-struct? drop f ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,11 @@ M: macosx reserved-area-size 6 cells ;
|
|||
|
||||
M: macosx lr-save 2 cells ;
|
||||
|
||||
M: float-regs param-regs 2drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
|
||||
M: ppc param-regs
|
||||
drop {
|
||||
{ int-regs { 3 4 5 6 7 8 9 10 } }
|
||||
{ float-regs { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
|
||||
} ;
|
||||
|
||||
M: ppc value-struct? drop t ;
|
||||
|
||||
|
|
|
|||
|
|
@ -226,10 +226,10 @@ M: spill-slot float-function-param* [ 1 ] dip n>> spill@ LFD ;
|
|||
M: integer float-function-param* FMR ;
|
||||
|
||||
: float-function-param ( i src -- )
|
||||
[ float-regs cdecl param-regs nth ] dip float-function-param* ;
|
||||
[ float-regs cdecl param-regs at nth ] dip float-function-param* ;
|
||||
|
||||
: float-function-return ( reg -- )
|
||||
float-regs return-reg double-rep %copy ;
|
||||
float-regs return-regs at first double-rep %copy ;
|
||||
|
||||
M:: ppc %unary-float-function ( dst src func -- )
|
||||
0 src float-function-param
|
||||
|
|
@ -665,11 +665,11 @@ M: ppc %reload ( dst rep src -- )
|
|||
|
||||
M: ppc %loop-entry ;
|
||||
|
||||
M: int-regs return-reg drop 3 ;
|
||||
|
||||
M: int-regs param-regs 2drop { 3 4 5 6 7 8 9 10 } ;
|
||||
|
||||
M: float-regs return-reg drop 1 ;
|
||||
M: ppc return-regs
|
||||
{
|
||||
{ int-regs { 3 4 5 6 } }
|
||||
{ float-regs { 1 } }
|
||||
} ;
|
||||
|
||||
M:: ppc %save-param-reg ( stack reg rep -- )
|
||||
reg stack local@ rep store-to-frame ;
|
||||
|
|
@ -697,7 +697,7 @@ M: spill-slot store-param [ 1 ] dip n>> spill@ STW ;
|
|||
M:: ppc %unbox ( src n rep func -- )
|
||||
src func call-unbox-func
|
||||
! Store the return value on the C stack
|
||||
n [ rep reg-class-of return-reg rep %save-param-reg ] when* ;
|
||||
n [ rep reg-class-of return-regs at first rep %save-param-reg ] when* ;
|
||||
|
||||
M:: ppc %unbox-long-long ( src n func -- )
|
||||
src func call-unbox-func
|
||||
|
|
|
|||
|
|
@ -2,11 +2,12 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: locals alien alien.c-types alien.libraries alien.syntax
|
||||
arrays kernel fry math namespaces sequences system layouts io
|
||||
vocabs.loader accessors init classes.struct combinators
|
||||
make words compiler.constants compiler.codegen.fixup
|
||||
compiler.cfg.instructions compiler.cfg.builder compiler.cfg.intrinsics
|
||||
compiler.cfg.stack-frame cpu.x86.assembler cpu.x86.assembler.operands
|
||||
cpu.x86 cpu.architecture vm ;
|
||||
vocabs.loader accessors init classes.struct combinators make
|
||||
words compiler.constants compiler.codegen.fixup
|
||||
compiler.cfg.instructions compiler.cfg.builder
|
||||
compiler.cfg.builder.alien.boxing compiler.cfg.intrinsics
|
||||
compiler.cfg.stack-frame cpu.x86.assembler
|
||||
cpu.x86.assembler.operands cpu.x86 cpu.architecture vm ;
|
||||
FROM: layouts => cell ;
|
||||
IN: cpu.x86.32
|
||||
|
||||
|
|
@ -20,19 +21,12 @@ M: x86.32 ds-reg ESI ;
|
|||
M: x86.32 rs-reg EDI ;
|
||||
M: x86.32 stack-reg ESP ;
|
||||
M: x86.32 frame-reg EBP ;
|
||||
M: x86.32 temp-reg ECX ;
|
||||
|
||||
M: x86.32 immediate-comparand? ( obj -- ? ) drop t ;
|
||||
|
||||
M:: x86.32 %load-vector ( dst val rep -- )
|
||||
dst 0 [] rep copy-memory* val rc-absolute rel-binary-literal ;
|
||||
|
||||
M: x86.32 %load-float ( dst val -- )
|
||||
<float> float-rep %load-vector ;
|
||||
|
||||
M: x86.32 %load-double ( dst val -- )
|
||||
<double> double-rep %load-vector ;
|
||||
|
||||
M: x86.32 %mov-vm-ptr ( reg -- )
|
||||
0 MOV 0 rc-absolute-cell rel-vm ;
|
||||
|
||||
|
|
@ -45,9 +39,6 @@ M: x86.32 %set-vm-field ( dst field -- )
|
|||
M: x86.32 %vm-field-ptr ( dst field -- )
|
||||
[ 0 MOV ] dip rc-absolute-cell rel-vm ;
|
||||
|
||||
: local@ ( n -- op )
|
||||
stack-frame get extra-stack-space dup 16 assert= + stack@ ;
|
||||
|
||||
M: x86.32 extra-stack-space calls-vm?>> 16 0 ? ;
|
||||
|
||||
M: x86.32 %mark-card
|
||||
|
|
@ -80,8 +71,6 @@ M: x86.32 pic-tail-reg EDX ;
|
|||
|
||||
M: x86.32 reserved-stack-space 0 ;
|
||||
|
||||
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
|
||||
|
||||
: save-vm-ptr ( n -- )
|
||||
stack@ 0 MOV 0 rc-absolute-cell rel-vm ;
|
||||
|
||||
|
|
@ -94,56 +83,19 @@ M: x86.32 return-struct-in-registers? ( c-type -- ? )
|
|||
|
||||
! On x86, parameters are usually never passed in registers,
|
||||
! except with Microsoft's "thiscall" and "fastcall" abis
|
||||
M: int-regs return-reg drop EAX ;
|
||||
M: float-regs param-regs 2drop { } ;
|
||||
|
||||
M: int-regs param-regs
|
||||
nip {
|
||||
{ thiscall [ { ECX } ] }
|
||||
{ fastcall [ { ECX EDX } ] }
|
||||
[ drop { } ]
|
||||
M: x86.32 param-regs
|
||||
{
|
||||
{ thiscall [ { { int-regs { ECX } } { float-regs { } } } ] }
|
||||
{ fastcall [ { { int-regs { ECX EDX } } { float-regs { } } } ] }
|
||||
[ drop { { int-regs { } } { float-regs { } } } ]
|
||||
} case ;
|
||||
|
||||
GENERIC: load-return-reg ( src rep -- )
|
||||
GENERIC: store-return-reg ( dst rep -- )
|
||||
|
||||
M: stack-params load-return-reg drop EAX swap MOV ;
|
||||
M: stack-params store-return-reg drop EAX MOV ;
|
||||
|
||||
M: int-rep load-return-reg drop EAX swap MOV ;
|
||||
M: int-rep store-return-reg drop EAX MOV ;
|
||||
|
||||
:: load-float-return ( src x87-insn sse-insn -- )
|
||||
src register? [
|
||||
ESP 4 SUB
|
||||
ESP [] src sse-insn execute
|
||||
ESP [] x87-insn execute
|
||||
ESP 4 ADD
|
||||
] [
|
||||
src x87-insn execute
|
||||
] if ; inline
|
||||
|
||||
:: store-float-return ( dst x87-insn sse-insn -- )
|
||||
dst register? [
|
||||
ESP 4 SUB
|
||||
ESP [] x87-insn execute
|
||||
dst ESP [] sse-insn execute
|
||||
ESP 4 ADD
|
||||
] [
|
||||
dst x87-insn execute
|
||||
] if ; inline
|
||||
|
||||
M: float-rep load-return-reg
|
||||
drop \ FLDS \ MOVSS load-float-return ;
|
||||
|
||||
M: float-rep store-return-reg
|
||||
drop \ FSTPS \ MOVSS store-float-return ;
|
||||
|
||||
M: double-rep load-return-reg
|
||||
drop \ FLDL \ MOVSD load-float-return ;
|
||||
|
||||
M: double-rep store-return-reg
|
||||
drop \ FSTPL \ MOVSD store-float-return ;
|
||||
! Need a fake return-reg for floats
|
||||
M: x86.32 return-regs
|
||||
{
|
||||
{ int-regs { EAX EDX } }
|
||||
{ float-regs { f } }
|
||||
} ;
|
||||
|
||||
M: x86.32 %prologue ( n -- )
|
||||
dup PUSH
|
||||
|
|
@ -153,6 +105,40 @@ M: x86.32 %prologue ( n -- )
|
|||
M: x86.32 %prepare-jump
|
||||
pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
|
||||
|
||||
:: load-float-return ( dst x87-insn sse-insn -- )
|
||||
dst register? [
|
||||
ESP 4 SUB
|
||||
ESP [] x87-insn execute
|
||||
dst ESP [] sse-insn execute
|
||||
ESP 4 ADD
|
||||
] [
|
||||
dst x87-insn execute
|
||||
] if ; inline
|
||||
|
||||
M: x86.32 %load-reg-param ( dst reg rep -- )
|
||||
[ ?spill-slot ] dip {
|
||||
{ int-rep [ MOV ] }
|
||||
{ float-rep [ drop \ FSTPS \ MOVSS load-float-return ] }
|
||||
{ double-rep [ drop \ FSTPL \ MOVSD load-float-return ] }
|
||||
} case ;
|
||||
|
||||
:: store-float-return ( src x87-insn sse-insn -- )
|
||||
src register? [
|
||||
ESP 4 SUB
|
||||
ESP [] src sse-insn execute
|
||||
ESP [] x87-insn execute
|
||||
ESP 4 ADD
|
||||
] [
|
||||
src x87-insn execute
|
||||
] if ; inline
|
||||
|
||||
M: x86.32 %store-reg-param ( src reg rep -- )
|
||||
[ ?spill-slot ] dip {
|
||||
{ int-rep [ swap MOV ] }
|
||||
{ float-rep [ \ FLDS \ MOVSS store-float-return ] }
|
||||
{ double-rep [ \ FLDL \ MOVSD store-float-return ] }
|
||||
} case ;
|
||||
|
||||
:: call-unbox-func ( src func -- )
|
||||
EAX src tagged-rep %copy
|
||||
4 save-vm-ptr
|
||||
|
|
@ -161,77 +147,29 @@ M: x86.32 %prepare-jump
|
|||
|
||||
M:: x86.32 %unbox ( dst src func rep -- )
|
||||
src func call-unbox-func
|
||||
dst ?spill-slot rep store-return-reg ;
|
||||
dst rep %load-return ;
|
||||
|
||||
M:: x86.32 %store-return ( src rep -- )
|
||||
src ?spill-slot rep load-return-reg ;
|
||||
|
||||
M:: x86.32 %store-long-long-return ( src1 src2 -- )
|
||||
src2 EAX = [ src1 src2 XCHG src2 src1 ] [ src1 src2 ] if :> ( src1 src2 )
|
||||
EAX src1 int-rep %copy
|
||||
EDX src2 int-rep %copy ;
|
||||
|
||||
M:: x86.32 %store-struct-return ( src c-type -- )
|
||||
EAX src int-rep %copy
|
||||
EDX EAX 4 [+] MOV
|
||||
EAX EAX [] MOV ;
|
||||
|
||||
M: stack-params copy-register*
|
||||
drop
|
||||
{
|
||||
{ [ dup integer? ] [ EAX swap next-stack@ MOV EAX MOV ] }
|
||||
{ [ over integer? ] [ EAX swap MOV param@ EAX MOV ] }
|
||||
} cond ;
|
||||
|
||||
M: x86.32 %save-param-reg [ local@ ] 2dip %copy ;
|
||||
|
||||
: (%box) ( n rep -- )
|
||||
#! If n is f, push the return register onto the stack; we
|
||||
#! 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 [ [ local@ ] dip load-return-reg ] [ 2drop ] if ;
|
||||
|
||||
M:: x86.32 %box ( dst n rep func -- )
|
||||
n rep (%box)
|
||||
M:: x86.32 %box ( dst src func rep -- )
|
||||
rep rep-size save-vm-ptr
|
||||
0 stack@ rep store-return-reg
|
||||
src rep %store-return
|
||||
0 stack@ rep %load-return
|
||||
func f %alien-invoke
|
||||
dst EAX tagged-rep %copy ;
|
||||
|
||||
: (%box-long-long) ( n -- )
|
||||
[
|
||||
[ EDX swap next-stack@ MOV ]
|
||||
[ EAX swap cell - next-stack@ MOV ] bi
|
||||
] when* ;
|
||||
|
||||
M:: x86.32 %box-long-long ( dst n func -- )
|
||||
n (%box-long-long)
|
||||
M:: x86.32 %box-long-long ( dst src1 src2 func -- )
|
||||
8 save-vm-ptr
|
||||
4 stack@ EDX MOV
|
||||
0 stack@ EAX MOV
|
||||
4 stack@ src1 int-rep %copy
|
||||
0 stack@ src2 int-rep %copy
|
||||
func f %alien-invoke
|
||||
dst EAX tagged-rep %copy ;
|
||||
|
||||
M: x86.32 struct-return@ ( n -- operand )
|
||||
[ next-stack@ ] [ stack-frame get params>> local@ ] if* ;
|
||||
|
||||
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
|
||||
M:: x86.32 %allot-byte-array ( dst size -- )
|
||||
4 save-vm-ptr
|
||||
0 stack@ size MOV
|
||||
"allot_byte_array" f %alien-invoke
|
||||
dst EAX tagged-rep %copy ;
|
||||
|
||||
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@ c-type heap-size MOV
|
||||
4 stack@ EDX MOV
|
||||
0 stack@ EAX MOV
|
||||
"from_small_struct" f %alien-invoke
|
||||
dst EAX tagged-rep %copy ;
|
||||
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
|
||||
|
||||
M: x86.32 %begin-callback ( -- )
|
||||
0 save-vm-ptr
|
||||
|
|
@ -309,7 +247,7 @@ M: x86.32 long-long-on-stack? t ;
|
|||
M: x86.32 float-on-stack? t ;
|
||||
|
||||
M: x86.32 flatten-struct-type
|
||||
stack-size cell /i { int-rep t } <repetition> ;
|
||||
call-next-method [ first t 2array ] map ;
|
||||
|
||||
M: x86.32 struct-return-on-stack? os linux? not ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
USING: alien alien.c-types cpu.architecture cpu.x86.64
|
||||
cpu.x86.assembler cpu.x86.assembler.operands tools.test ;
|
||||
cpu.x86.assembler cpu.x86.assembler.operands tools.test
|
||||
assocs sequences ;
|
||||
IN: cpu.x86.64.tests
|
||||
|
||||
: assembly-test-1 ( -- x ) int { } cdecl [ RAX 3 MOV ] alien-assembly ;
|
||||
|
|
@ -9,7 +10,7 @@ IN: cpu.x86.64.tests
|
|||
: assembly-test-2 ( a b -- x )
|
||||
int { int int } cdecl [
|
||||
param-reg-0 param-reg-1 ADD
|
||||
int-regs return-reg param-reg-0 MOV
|
||||
int-regs return-regs at first param-reg-0 MOV
|
||||
] alien-assembly ;
|
||||
|
||||
[ 23 ] [ 17 6 assembly-test-2 ] unit-test
|
||||
|
|
|
|||
|
|
@ -11,15 +11,20 @@ cpu.architecture vm ;
|
|||
FROM: layouts => cell cells ;
|
||||
IN: cpu.x86.64
|
||||
|
||||
: param-reg-0 ( -- reg ) 0 int-regs cdecl param-reg ; inline
|
||||
: param-reg-1 ( -- reg ) 1 int-regs cdecl param-reg ; inline
|
||||
: param-reg-2 ( -- reg ) 2 int-regs cdecl param-reg ; inline
|
||||
: param-reg-3 ( -- reg ) 3 int-regs cdecl param-reg ; inline
|
||||
: param-reg ( n -- reg ) int-regs cdecl param-regs at nth ;
|
||||
|
||||
: param-reg-0 ( -- reg ) 0 param-reg ; inline
|
||||
: param-reg-1 ( -- reg ) 1 param-reg ; inline
|
||||
: param-reg-2 ( -- reg ) 2 param-reg ; inline
|
||||
: param-reg-3 ( -- reg ) 3 param-reg ; inline
|
||||
|
||||
M: x86.64 pic-tail-reg RBX ;
|
||||
|
||||
M: int-regs return-reg drop RAX ;
|
||||
M: float-regs return-reg drop XMM0 ;
|
||||
M: x86.64 return-regs
|
||||
{
|
||||
{ int-regs { RAX EDX } }
|
||||
{ float-regs { XMM0 XMM1 } }
|
||||
} ;
|
||||
|
||||
M: x86.64 ds-reg R14 ;
|
||||
M: x86.64 rs-reg R15 ;
|
||||
|
|
@ -49,18 +54,16 @@ M: x86.64 %vm-field ( dst offset -- )
|
|||
M:: x86.64 %load-vector ( dst val rep -- )
|
||||
dst 0 [RIP+] rep copy-memory* val rc-relative rel-binary-literal ;
|
||||
|
||||
M: x86.64 %load-float ( dst val -- )
|
||||
<float> float-rep %load-vector ;
|
||||
|
||||
M: x86.64 %load-double ( dst val -- )
|
||||
<double> double-rep %load-vector ;
|
||||
|
||||
M: x86.64 %set-vm-field ( src offset -- )
|
||||
[ vm-reg ] dip [+] swap MOV ;
|
||||
|
||||
M: x86.64 %vm-field-ptr ( dst offset -- )
|
||||
[ vm-reg ] dip [+] LEA ;
|
||||
|
||||
! Must be a volatile register not used for parameter passing or
|
||||
! integer return
|
||||
HOOK: temp-reg cpu ( -- reg )
|
||||
|
||||
M: x86.64 %prologue ( n -- )
|
||||
temp-reg -7 [RIP+] LEA
|
||||
dup PUSH
|
||||
|
|
@ -99,85 +102,29 @@ M:: x86.64 %dispatch ( src temp -- )
|
|||
[ (align-code) ]
|
||||
bi ;
|
||||
|
||||
M:: x86.64 %load-reg-param ( dst reg rep -- )
|
||||
dst reg rep %copy ;
|
||||
|
||||
M:: x86.64 %store-reg-param ( src reg rep -- )
|
||||
reg src rep %copy ;
|
||||
|
||||
M:: x86.64 %unbox ( dst src func rep -- )
|
||||
param-reg-0 src tagged-rep %copy
|
||||
param-reg-1 %mov-vm-ptr
|
||||
func f %alien-invoke
|
||||
dst rep reg-class-of return-reg rep %copy ;
|
||||
dst rep %load-return ;
|
||||
|
||||
: with-return-regs ( quot -- )
|
||||
[
|
||||
V{ RDX RAX } clone int-regs set
|
||||
V{ XMM1 XMM0 } clone float-regs set
|
||||
call
|
||||
] with-scope ; inline
|
||||
|
||||
: each-struct-component ( c-type quot -- )
|
||||
'[
|
||||
flatten-struct-type
|
||||
[ [ first ] dip @ ] each-index
|
||||
] with-return-regs ; inline
|
||||
|
||||
: %unbox-struct-component ( rep i -- )
|
||||
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 %store-return ( src rep -- )
|
||||
rep reg-class-of return-reg src rep %copy ;
|
||||
|
||||
M:: x86.64 %store-struct-return ( src c-type -- )
|
||||
! Move src to R11 so that we don't clobber it.
|
||||
R11 src int-rep %copy
|
||||
c-type [ %unbox-struct-component ] each-struct-component ;
|
||||
|
||||
M: stack-params copy-register*
|
||||
drop
|
||||
{
|
||||
{ [ dup integer? ] [ R11 swap next-stack@ MOV R11 MOV ] }
|
||||
{ [ over integer? ] [ R11 swap MOV param@ R11 MOV ] }
|
||||
} cond ;
|
||||
|
||||
M: x86.64 %save-param-reg [ param@ ] 2dip %copy ;
|
||||
|
||||
M:: x86.64 %box ( dst n rep func -- )
|
||||
0 rep reg-class-of cdecl param-reg
|
||||
n [ n param@ ] [ rep reg-class-of return-reg ] if rep %copy
|
||||
M:: x86.64 %box ( dst src func rep -- )
|
||||
0 rep reg-class-of cdecl param-regs at nth src rep %copy
|
||||
rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr
|
||||
func f %alien-invoke
|
||||
dst RAX tagged-rep %copy ;
|
||||
dst int-rep %load-return ;
|
||||
|
||||
: box-struct-component@ ( i -- operand ) 1 + cells param@ ;
|
||||
|
||||
: %box-struct-component ( rep i -- )
|
||||
box-struct-component@ swap reg-class-of {
|
||||
{ int-regs [ int-regs get pop MOV ] }
|
||||
{ float-regs [ float-regs get pop MOVSD ] }
|
||||
} case ;
|
||||
|
||||
M:: x86.64 %box-small-struct ( dst c-type -- )
|
||||
#! Box a <= 16-byte struct.
|
||||
c-type [ %box-struct-component ] each-struct-component
|
||||
param-reg-2 c-type heap-size MOV
|
||||
param-reg-0 0 box-struct-component@ MOV
|
||||
param-reg-1 1 box-struct-component@ MOV
|
||||
param-reg-3 %mov-vm-ptr
|
||||
"from_small_struct" f %alien-invoke
|
||||
dst RAX tagged-rep %copy ;
|
||||
|
||||
M: x86.64 struct-return@ ( n -- operand )
|
||||
[ stack-frame get params>> ] unless* param@ ;
|
||||
|
||||
M:: x86.64 %box-large-struct ( dst n c-type -- )
|
||||
! Struct size is parameter 2
|
||||
param-reg-1 c-type heap-size MOV
|
||||
! Compute destination address
|
||||
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
|
||||
dst RAX tagged-rep %copy ;
|
||||
M:: x86.64 %allot-byte-array ( dst size -- )
|
||||
param-reg-0 size MOV
|
||||
param-reg-1 %mov-vm-ptr
|
||||
"allot_byte_array" f %alien-invoke
|
||||
dst int-rep %load-return ;
|
||||
|
||||
M: x86.64 %alien-invoke
|
||||
R11 0 MOV
|
||||
|
|
@ -198,15 +145,12 @@ M: x86.64 %end-callback ( -- )
|
|||
"end_callback" f %alien-invoke ;
|
||||
|
||||
: float-function-param ( i src -- )
|
||||
[ float-regs cdecl param-regs nth ] dip double-rep %copy ;
|
||||
|
||||
: float-function-return ( reg -- )
|
||||
float-regs return-reg double-rep %copy ;
|
||||
[ float-regs cdecl param-regs at nth ] dip double-rep %copy ;
|
||||
|
||||
M:: x86.64 %unary-float-function ( dst src func -- )
|
||||
0 src float-function-param
|
||||
func "libm" load-library %alien-invoke
|
||||
dst float-function-return ;
|
||||
dst double-rep %load-return ;
|
||||
|
||||
M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
|
||||
! src1 might equal dst; otherwise it will be a spill slot
|
||||
|
|
@ -214,7 +158,7 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
|
|||
0 src1 float-function-param
|
||||
1 src2 float-function-param
|
||||
func "libm" load-library %alien-invoke
|
||||
dst float-function-return ;
|
||||
dst double-rep %load-return ;
|
||||
|
||||
M:: x86.64 %call-gc ( gc-roots -- )
|
||||
param-reg-0 gc-roots gc-root-offsets %load-reference
|
||||
|
|
|
|||
|
|
@ -3,14 +3,18 @@
|
|||
USING: accessors arrays sequences math splitting make assocs
|
||||
kernel layouts system alien.c-types classes.struct
|
||||
cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands
|
||||
cpu.x86 compiler.cfg.builder.alien compiler.cfg.registers ;
|
||||
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: float-regs param-regs
|
||||
2drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
|
||||
M: x86.64 param-regs
|
||||
drop {
|
||||
{ int-regs { RDI RSI RDX RCX R8 R9 } }
|
||||
{ float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
|
||||
} ;
|
||||
|
||||
M: x86.64 reserved-stack-space 0 ;
|
||||
|
||||
|
|
@ -31,13 +35,9 @@ M: x86.64 reserved-stack-space 0 ;
|
|||
f 2array
|
||||
] map ;
|
||||
|
||||
: flatten-large-struct ( c-type -- seq )
|
||||
stack-size cell /i { int-rep t } <repetition> ;
|
||||
|
||||
M: x86.64 flatten-struct-type ( c-type -- seq )
|
||||
dup heap-size 16 >
|
||||
[ flatten-large-struct ]
|
||||
[ flatten-small-struct ] if ;
|
||||
dup heap-size 16 <=
|
||||
[ flatten-small-struct ] [ call-next-method [ first t 2array ] map ] if ;
|
||||
|
||||
M: x86.64 return-struct-in-registers? ( c-type -- ? )
|
||||
heap-size 2 cells <= ;
|
||||
|
|
|
|||
|
|
@ -1,13 +1,15 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel layouts system math alien.c-types sequences
|
||||
compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86
|
||||
cpu.x86.assembler.operands ;
|
||||
compiler.cfg.registers cpu.architecture cpu.x86.assembler
|
||||
cpu.x86 cpu.x86.64 cpu.x86.assembler.operands ;
|
||||
IN: cpu.x86.64.winnt
|
||||
|
||||
M: int-regs param-regs 2drop { RCX RDX R8 R9 } ;
|
||||
|
||||
M: float-regs param-regs 2drop { XMM0 XMM1 XMM2 XMM3 } ;
|
||||
M: x86.64 param-regs
|
||||
drop {
|
||||
{ int-regs { RCX RDX R8 R9 } }
|
||||
{ float-regs { XMM0 XMM1 XMM2 XMM3 } }
|
||||
} ;
|
||||
|
||||
M: x86.64 reserved-stack-space 4 cells ;
|
||||
|
||||
|
|
@ -23,4 +25,3 @@ M: x86.64 dummy-int-params? t ;
|
|||
M: x86.64 dummy-fp-params? t ;
|
||||
|
||||
M: x86.64 temp-reg R11 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,13 +1,16 @@
|
|||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.c-types combinators compiler
|
||||
compiler.codegen.fixup compiler.units cpu.architecture
|
||||
cpu.x86.assembler cpu.x86.assembler.operands init io kernel
|
||||
locals math math.order math.parser memoize namespaces system ;
|
||||
USING: accessors assocs sequences alien alien.c-types
|
||||
combinators compiler compiler.codegen.fixup compiler.units
|
||||
cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands
|
||||
init io kernel locals math math.order math.parser memoize
|
||||
namespaces system ;
|
||||
IN: cpu.x86.features
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: return-reg ( -- reg ) int-regs return-regs at first ;
|
||||
|
||||
: (sse-version) ( -- n )
|
||||
int { } cdecl [
|
||||
"sse-42" define-label
|
||||
|
|
@ -18,7 +21,7 @@ IN: cpu.x86.features
|
|||
"sse-1" define-label
|
||||
"end" define-label
|
||||
|
||||
int-regs return-reg 1 MOV
|
||||
return-reg 1 MOV
|
||||
|
||||
CPUID
|
||||
|
||||
|
|
@ -40,31 +43,31 @@ IN: cpu.x86.features
|
|||
EDX 25 BT
|
||||
"sse-1" get JB
|
||||
|
||||
int-regs return-reg 0 MOV
|
||||
return-reg 0 MOV
|
||||
"end" get JMP
|
||||
|
||||
"sse-42" resolve-label
|
||||
int-regs return-reg 42 MOV
|
||||
return-reg 42 MOV
|
||||
"end" get JMP
|
||||
|
||||
"sse-41" resolve-label
|
||||
int-regs return-reg 41 MOV
|
||||
return-reg 41 MOV
|
||||
"end" get JMP
|
||||
|
||||
"ssse-3" resolve-label
|
||||
int-regs return-reg 33 MOV
|
||||
return-reg 33 MOV
|
||||
"end" get JMP
|
||||
|
||||
"sse-3" resolve-label
|
||||
int-regs return-reg 30 MOV
|
||||
return-reg 30 MOV
|
||||
"end" get JMP
|
||||
|
||||
"sse-2" resolve-label
|
||||
int-regs return-reg 20 MOV
|
||||
return-reg 20 MOV
|
||||
"end" get JMP
|
||||
|
||||
"sse-1" resolve-label
|
||||
int-regs return-reg 10 MOV
|
||||
return-reg 10 MOV
|
||||
|
||||
"end" resolve-label
|
||||
] alien-assembly ;
|
||||
|
|
|
|||
|
|
@ -38,11 +38,7 @@ HOOK: extra-stack-space cpu ( stack-frame -- n )
|
|||
stack-frame get extra-stack-space +
|
||||
reserved-stack-space + ;
|
||||
|
||||
: special@ ( n -- op ) special-offset stack@ ;
|
||||
|
||||
: spill@ ( n -- op ) spill-offset special@ ;
|
||||
|
||||
: param@ ( n -- op ) reserved-stack-space + stack@ ;
|
||||
: spill@ ( n -- op ) spill-offset special-offset stack@ ;
|
||||
|
||||
: gc-root-offsets ( seq -- seq' )
|
||||
[ n>> spill-offset special-offset cell + ] map f like ;
|
||||
|
|
@ -62,10 +58,6 @@ M: x86 stack-frame-size ( stack-frame -- i )
|
|||
3 cells +
|
||||
align-stack ;
|
||||
|
||||
! Must be a volatile register not used for parameter passing or
|
||||
! integer return
|
||||
HOOK: temp-reg cpu ( -- reg )
|
||||
|
||||
HOOK: pic-tail-reg cpu ( -- reg )
|
||||
|
||||
M: x86 complex-addressing? t ;
|
||||
|
|
@ -83,6 +75,12 @@ M: x86 %load-reference
|
|||
[ \ f type-number MOV ]
|
||||
if* ;
|
||||
|
||||
M: x86 %load-float ( dst val -- )
|
||||
<float> float-rep %load-vector ;
|
||||
|
||||
M: x86 %load-double ( dst val -- )
|
||||
<double> double-rep %load-vector ;
|
||||
|
||||
HOOK: ds-reg cpu ( -- reg )
|
||||
HOOK: rs-reg cpu ( -- reg )
|
||||
|
||||
|
|
@ -1500,16 +1498,27 @@ M:: x86 %spill ( src rep dst -- )
|
|||
M:: x86 %reload ( dst rep src -- )
|
||||
dst src rep %copy ;
|
||||
|
||||
M:: x86 %store-reg-param ( src reg rep -- )
|
||||
reg src rep %copy ;
|
||||
|
||||
M:: x86 %store-stack-param ( src n rep -- )
|
||||
n param@ src rep %copy ;
|
||||
n reserved-stack-space + stack@ src rep %copy ;
|
||||
|
||||
HOOK: struct-return@ cpu ( n -- operand )
|
||||
: %load-return ( dst rep -- )
|
||||
[ reg-class-of return-regs at first ] keep %load-reg-param ;
|
||||
|
||||
M: x86 %prepare-struct-area ( dst -- )
|
||||
f struct-return@ LEA ;
|
||||
: %store-return ( dst rep -- )
|
||||
[ reg-class-of return-regs at first ] keep %store-reg-param ;
|
||||
|
||||
: next-stack@ ( n -- operand )
|
||||
#! nth parameter from the next stack frame. Used to box
|
||||
#! input values to callbacks; the callback has its own
|
||||
#! stack frame set up, and we want to read the frame
|
||||
#! set up by the caller.
|
||||
frame-reg swap 2 cells + [+] ;
|
||||
|
||||
M:: x86 %load-stack-param ( dst n rep -- )
|
||||
dst n next-stack@ rep %copy ;
|
||||
|
||||
M: x86 %prepare-struct-caller ( dst -- )
|
||||
return-offset special-offset stack@ LEA ;
|
||||
|
||||
M: x86 %alien-indirect ( src -- )
|
||||
?spill-slot CALL ;
|
||||
|
|
@ -1540,13 +1549,6 @@ M: x86 immediate-arithmetic? ( n -- ? )
|
|||
M: x86 immediate-bitwise? ( n -- ? )
|
||||
HEX: -80000000 HEX: 7fffffff between? ;
|
||||
|
||||
: next-stack@ ( n -- operand )
|
||||
#! nth parameter from the next stack frame. Used to box
|
||||
#! input values to callbacks; the callback has its own
|
||||
#! stack frame set up, and we want to read the frame
|
||||
#! set up by the caller.
|
||||
frame-reg swap 2 cells + [+] ;
|
||||
|
||||
enable-min/max
|
||||
enable-log2
|
||||
|
||||
|
|
|
|||
|
|
@ -1,25 +1,25 @@
|
|||
USING: alien alien.c-types cpu.architecture cpu.x86.assembler
|
||||
USING: alien alien.c-types cpu.x86.64 cpu.x86.assembler
|
||||
cpu.x86.assembler.operands math.floats.env.x86 sequences system ;
|
||||
IN: math.floats.env.x86.64
|
||||
|
||||
M: x86.64 get-sse-env
|
||||
void { void* } cdecl [
|
||||
int-regs cdecl param-regs first [] STMXCSR
|
||||
param-reg-0 [] STMXCSR
|
||||
] alien-assembly ;
|
||||
|
||||
M: x86.64 set-sse-env
|
||||
void { void* } cdecl [
|
||||
int-regs cdecl param-regs first [] LDMXCSR
|
||||
param-reg-0 [] LDMXCSR
|
||||
] alien-assembly ;
|
||||
|
||||
M: x86.64 get-x87-env
|
||||
void { void* } cdecl [
|
||||
int-regs cdecl param-regs first [] FNSTSW
|
||||
int-regs cdecl param-regs first 2 [+] FNSTCW
|
||||
param-reg-0 [] FNSTSW
|
||||
param-reg-0 2 [+] FNSTCW
|
||||
] alien-assembly ;
|
||||
|
||||
M: x86.64 set-x87-env
|
||||
void { void* } cdecl [
|
||||
FNCLEX
|
||||
int-regs cdecl param-regs first 2 [+] FLDCW
|
||||
param-reg-0 2 [+] FLDCW
|
||||
] alien-assembly ;
|
||||
|
|
|
|||
|
|
@ -2,9 +2,9 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences accessors combinators math namespaces
|
||||
init sets words assocs alien.libraries alien alien.private
|
||||
alien.c-types fry stack-checker.backend
|
||||
alien.c-types fry quotations stack-checker.backend
|
||||
stack-checker.errors stack-checker.visitor
|
||||
stack-checker.dependencies ;
|
||||
stack-checker.dependencies compiler.utilities ;
|
||||
IN: stack-checker.alien
|
||||
|
||||
TUPLE: alien-node-params return parameters abi in-d out-d ;
|
||||
|
|
@ -104,6 +104,18 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
|
|||
: callback-bottom ( params -- )
|
||||
xt>> '[ _ callback-xt ] infer-quot-here ;
|
||||
|
||||
: callback-return-quot ( ctype -- quot )
|
||||
return>> [ [ ] ] [ c-type c-type-unboxer-quot ] if-void ;
|
||||
|
||||
: callback-prep-quot ( params -- quot )
|
||||
parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
|
||||
|
||||
: wrap-callback-quot ( params -- quot )
|
||||
[ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append
|
||||
yield-hook get
|
||||
'[ _ _ do-callback ]
|
||||
>quotation ;
|
||||
|
||||
: infer-alien-callback ( -- )
|
||||
alien-callback-params new
|
||||
pop-quot
|
||||
|
|
@ -111,5 +123,6 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
|
|||
pop-params
|
||||
pop-return
|
||||
"( callback )" <uninterned-word> >>xt
|
||||
dup wrap-callback-quot >>quot
|
||||
dup callback-bottom
|
||||
#alien-callback, ;
|
||||
|
|
|
|||
43
vm/alien.cpp
43
vm/alien.cpp
|
|
@ -187,47 +187,4 @@ VM_C_API char *alien_offset(cell obj, factor_vm *parent)
|
|||
return parent->alien_offset(obj);
|
||||
}
|
||||
|
||||
/* For FFI callbacks receiving structs by value */
|
||||
cell factor_vm::from_value_struct(void *src, cell size)
|
||||
{
|
||||
byte_array *bytes = allot_byte_array(size);
|
||||
memcpy(bytes->data<void>(),src,size);
|
||||
return tag<byte_array>(bytes);
|
||||
}
|
||||
|
||||
VM_C_API cell from_value_struct(void *src, cell size, factor_vm *parent)
|
||||
{
|
||||
return parent->from_value_struct(src,size);
|
||||
}
|
||||
|
||||
/* On some x86 OSes, structs <= 8 bytes are returned in registers. */
|
||||
cell factor_vm::from_small_struct(cell x, cell y, cell size)
|
||||
{
|
||||
cell data[2];
|
||||
data[0] = x;
|
||||
data[1] = y;
|
||||
return from_value_struct(data,size);
|
||||
}
|
||||
|
||||
VM_C_API cell from_small_struct(cell x, cell y, cell size, factor_vm *parent)
|
||||
{
|
||||
return parent->from_small_struct(x,y,size);
|
||||
}
|
||||
|
||||
/* On OS X/PPC, complex numbers are returned in registers. */
|
||||
cell factor_vm::from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
|
||||
{
|
||||
cell data[4];
|
||||
data[0] = x1;
|
||||
data[1] = x2;
|
||||
data[2] = x3;
|
||||
data[3] = x4;
|
||||
return from_value_struct(data,size);
|
||||
}
|
||||
|
||||
VM_C_API cell from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *parent)
|
||||
{
|
||||
return parent->from_medium_struct(x1, x2, x3, x4, size);
|
||||
}
|
||||
|
||||
}
|
||||
|
|
|
|||
|
|
@ -4,8 +4,5 @@ namespace factor
|
|||
VM_C_API char *alien_offset(cell object, factor_vm *vm);
|
||||
VM_C_API char *pinned_alien_offset(cell object, factor_vm *vm);
|
||||
VM_C_API cell allot_alien(void *address, factor_vm *vm);
|
||||
VM_C_API cell from_value_struct(void *src, cell size, factor_vm *vm);
|
||||
VM_C_API cell from_small_struct(cell x, cell y, cell size, factor_vm *vm);
|
||||
VM_C_API cell from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *vm);
|
||||
|
||||
}
|
||||
|
|
|
|||
|
|
@ -10,6 +10,11 @@ byte_array *factor_vm::allot_byte_array(cell size)
|
|||
return array;
|
||||
}
|
||||
|
||||
VM_C_API cell allot_byte_array(cell size, factor_vm *parent)
|
||||
{
|
||||
return tag<byte_array>(parent->allot_byte_array(size));
|
||||
}
|
||||
|
||||
void factor_vm::primitive_byte_array()
|
||||
{
|
||||
cell size = unbox_array_size();
|
||||
|
|
|
|||
|
|
@ -20,4 +20,6 @@ template<typename Type> byte_array *factor_vm::byte_array_from_value(Type *value
|
|||
return data;
|
||||
}
|
||||
|
||||
VM_C_API cell allot_byte_array(cell size, factor_vm *parent);
|
||||
|
||||
}
|
||||
|
|
|
|||
|
|
@ -615,9 +615,6 @@ struct factor_vm
|
|||
void primitive_dlclose();
|
||||
void primitive_dll_validp();
|
||||
char *alien_offset(cell obj);
|
||||
cell from_value_struct(void *src, cell size);
|
||||
cell from_small_struct(cell x, cell y, cell size);
|
||||
cell from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size);
|
||||
|
||||
// quotations
|
||||
void primitive_jit_compile();
|
||||
|
|
|
|||
Loading…
Reference in New Issue