Merge branch 'master' of git://factorcode.org/git/factor
Anton Gorenko
commit
83819c9902
|
|
@ -26,8 +26,6 @@ M: array base-type drop void* base-type ;
|
|||
|
||||
M: array stack-size drop void* stack-size ;
|
||||
|
||||
M: array flatten-c-type drop void* flatten-c-type ;
|
||||
|
||||
PREDICATE: string-type < pair
|
||||
first2 [ c-string = ] [ word? ] bi* and ;
|
||||
|
||||
|
|
@ -49,8 +47,6 @@ M: string-type stack-size drop void* stack-size ;
|
|||
|
||||
M: string-type c-type-rep drop int-rep ;
|
||||
|
||||
M: string-type flatten-c-type drop void* flatten-c-type ;
|
||||
|
||||
M: string-type c-type-boxer-quot
|
||||
second dup binary =
|
||||
[ drop void* c-type-boxer-quot ]
|
||||
|
|
|
|||
|
|
@ -66,15 +66,6 @@ M: word c-type
|
|||
dup "c-type" word-prop resolve-typedef
|
||||
[ ] [ no-c-type ] ?if ;
|
||||
|
||||
GENERIC: c-struct? ( c-type -- ? )
|
||||
|
||||
M: object c-struct? drop f ;
|
||||
|
||||
M: c-type-name c-struct? dup void? [ drop f ] [ c-type c-struct? ] if ;
|
||||
|
||||
! These words being foldable means that words need to be
|
||||
! recompiled if a C type is redefined. Even so, folding the
|
||||
! size facilitates some optimizations.
|
||||
GENERIC: c-type-class ( name -- class )
|
||||
|
||||
M: abstract-c-type c-type-class class>> ;
|
||||
|
|
@ -127,17 +118,6 @@ GENERIC: stack-size ( name -- size )
|
|||
|
||||
M: c-type stack-size size>> cell align ;
|
||||
|
||||
: (flatten-c-type) ( type rep -- seq )
|
||||
[ stack-size cell /i ] dip <repetition> ; inline
|
||||
|
||||
GENERIC: flatten-c-type ( type -- reps )
|
||||
|
||||
M: c-type flatten-c-type rep>> 1array ;
|
||||
M: c-type-name flatten-c-type c-type flatten-c-type ;
|
||||
|
||||
: flatten-c-types ( types -- reps )
|
||||
[ flatten-c-type ] map concat ;
|
||||
|
||||
MIXIN: value-type
|
||||
|
||||
: c-getter ( name -- quot )
|
||||
|
|
@ -165,8 +145,7 @@ PROTOCOL: c-type-protocol
|
|||
c-type-align-first
|
||||
base-type
|
||||
heap-size
|
||||
stack-size
|
||||
flatten-c-type ;
|
||||
stack-size ;
|
||||
|
||||
CONSULT: c-type-protocol c-type-name
|
||||
c-type ;
|
||||
|
|
@ -185,9 +164,6 @@ TUPLE: long-long-type < c-type ;
|
|||
: <long-long-type> ( -- c-type )
|
||||
long-long-type new ;
|
||||
|
||||
M: long-long-type flatten-c-type
|
||||
int-rep (flatten-c-type) ;
|
||||
|
||||
: define-deref ( c-type -- )
|
||||
[ name>> CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
|
||||
(( c-ptr -- value )) define-inline ;
|
||||
|
|
|
|||
|
|
@ -119,10 +119,6 @@ HELP: typedef
|
|||
|
||||
{ POSTPONE: TYPEDEF: typedef } related-words
|
||||
|
||||
HELP: c-struct?
|
||||
{ $values { "c-type" "a C type" } { "?" "a boolean" } }
|
||||
{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: STRUCT: } "." } ;
|
||||
|
||||
HELP: C-GLOBAL:
|
||||
{ $syntax "C-GLOBAL: type name" }
|
||||
{ $values { "type" "a C type" } { "name" "a C global variable name" } }
|
||||
|
|
|
|||
|
|
@ -166,24 +166,22 @@ INSTANCE: struct-c-type value-type
|
|||
|
||||
M: struct-c-type c-type ;
|
||||
|
||||
: if-value-struct ( ctype true false -- )
|
||||
[ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
|
||||
|
||||
: if-small-struct ( c-type true false -- ? )
|
||||
[ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline
|
||||
|
||||
M: struct-c-type base-type ;
|
||||
|
||||
M: struct-c-type stack-size
|
||||
[ heap-size cell align ] [ stack-size ] if-value-struct ;
|
||||
dup value-struct? [ heap-size cell align ] [ drop cell ] if ;
|
||||
|
||||
HOOK: flatten-struct-type cpu ( type -- reps )
|
||||
HOOK: flatten-struct-type cpu ( type -- pairs )
|
||||
|
||||
M: object flatten-struct-type int-rep (flatten-c-type) ;
|
||||
M: object flatten-struct-type
|
||||
stack-size cell /i { int-rep f } <repetition> ;
|
||||
|
||||
M: struct-c-type flatten-c-type flatten-struct-type ;
|
||||
|
||||
M: struct-c-type c-struct? drop t ;
|
||||
: large-struct? ( type -- ? )
|
||||
{
|
||||
{ [ dup void? ] [ drop f ] }
|
||||
{ [ dup base-type struct-c-type? not ] [ drop f ] }
|
||||
[ return-struct-in-registers? not ]
|
||||
} cond ;
|
||||
|
||||
<PRIVATE
|
||||
: struct-slot-values-quot ( class -- quot )
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.c-types alien.strings arrays assocs
|
||||
classes.struct continuations combinators compiler compiler.alien
|
||||
classes.struct continuations combinators compiler
|
||||
core-graphics.types stack-checker kernel math namespaces make
|
||||
quotations sequences strings words cocoa.runtime cocoa.types io
|
||||
macros memoize io.encodings.utf8 effects layouts libc
|
||||
|
|
|
|||
|
|
@ -1,15 +0,0 @@
|
|||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel namespaces make math sequences layouts
|
||||
alien.c-types cpu.architecture ;
|
||||
IN: compiler.alien
|
||||
|
||||
: large-struct? ( type -- ? )
|
||||
dup c-struct? [ return-struct-in-registers? not ] [ drop f ] if ;
|
||||
|
||||
: alien-parameters ( params -- seq )
|
||||
dup parameters>>
|
||||
swap return>> large-struct? [ struct-return-pointer-type prefix ] when ;
|
||||
|
||||
: alien-return ( params -- type )
|
||||
return>> dup large-struct? [ drop void ] when ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Common code used for analysis and code generation of alien bindings
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
USING: arrays compiler.cfg.alias-analysis compiler.cfg.instructions
|
||||
compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
|
||||
cpu.architecture tools.test ;
|
||||
cpu.architecture tools.test byte-arrays layouts literals alien ;
|
||||
IN: compiler.cfg.alias-analysis.tests
|
||||
|
||||
! Redundant load elimination
|
||||
|
|
@ -242,3 +242,22 @@ IN: compiler.cfg.alias-analysis.tests
|
|||
T{ ##compare f 2 0 1 cc= }
|
||||
} alias-analysis-step
|
||||
] unit-test
|
||||
|
||||
! Make sure that input to ##box-displaced-alien becomes heap-ac
|
||||
[
|
||||
V{
|
||||
T{ ##allot f 1 16 byte-array }
|
||||
T{ ##load-reference f 2 10 }
|
||||
T{ ##box-displaced-alien f 3 2 1 4 byte-array }
|
||||
T{ ##slot-imm f 5 3 1 $[ alien type-number ] }
|
||||
T{ ##compare f 6 5 1 cc= }
|
||||
}
|
||||
] [
|
||||
V{
|
||||
T{ ##allot f 1 16 byte-array }
|
||||
T{ ##load-reference f 2 10 }
|
||||
T{ ##box-displaced-alien f 3 2 1 4 byte-array }
|
||||
T{ ##slot-imm f 5 3 1 $[ alien type-number ] }
|
||||
T{ ##compare f 6 5 1 cc= }
|
||||
} alias-analysis-step
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -255,6 +255,10 @@ M: ##allocation analyze-aliases*
|
|||
#! object.
|
||||
dup dst>> set-new-ac ;
|
||||
|
||||
M: ##box-displaced-alien analyze-aliases*
|
||||
[ call-next-method ]
|
||||
[ base>> heap-ac get merge-acs ] bi ;
|
||||
|
||||
M: ##read analyze-aliases*
|
||||
call-next-method
|
||||
dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
|
||||
|
|
|
|||
|
|
@ -1,121 +1,86 @@
|
|||
! 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 fry sequences locals alien alien.private
|
||||
alien.strings alien.c-types alien.libraries classes.struct
|
||||
namespaces kernel strings libc quotations cpu.architecture
|
||||
compiler.alien compiler.utilities compiler.tree compiler.cfg
|
||||
compiler.cfg.builder compiler.cfg.builder.blocks
|
||||
compiler.cfg.instructions compiler.cfg.stack-frame
|
||||
compiler.cfg.stacks compiler.cfg.registers
|
||||
compiler.cfg.hats ;
|
||||
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
|
||||
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 ;
|
||||
FROM: compiler.errors => no-such-symbol no-such-library ;
|
||||
IN: compiler.cfg.builder.alien
|
||||
|
||||
GENERIC: next-fastcall-param ( rep -- )
|
||||
! output is triples with shape { vreg rep on-stack? }
|
||||
GENERIC: unbox ( src c-type -- vregs )
|
||||
|
||||
: ?dummy-stack-params ( rep -- )
|
||||
dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;
|
||||
M: c-type unbox
|
||||
[ [ unboxer>> ] [ rep>> ] bi ^^unbox ] [ rep>> ] bi
|
||||
f 3array 1array ;
|
||||
|
||||
: ?dummy-int-params ( rep -- )
|
||||
dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ;
|
||||
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 ;
|
||||
|
||||
: ?dummy-fp-params ( rep -- )
|
||||
drop dummy-fp-params? [ float-regs inc ] when ;
|
||||
GENERIC: unbox-parameter ( src c-type -- vregs )
|
||||
|
||||
M: int-rep next-fastcall-param
|
||||
int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;
|
||||
M: c-type unbox-parameter unbox ;
|
||||
|
||||
M: float-rep next-fastcall-param
|
||||
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
|
||||
M: long-long-type unbox-parameter unbox ;
|
||||
|
||||
M: double-rep next-fastcall-param
|
||||
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
|
||||
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 ;
|
||||
|
||||
GENERIC# reg-class-full? 1 ( reg-class abi -- ? )
|
||||
|
||||
M: stack-params reg-class-full? 2drop t ;
|
||||
|
||||
M: reg-class reg-class-full?
|
||||
[ get ] swap '[ _ param-regs length ] bi >= ;
|
||||
|
||||
: alloc-stack-param ( rep -- n reg-class rep )
|
||||
stack-params get
|
||||
[ rep-size cell align stack-params +@ ] dip
|
||||
stack-params dup ;
|
||||
|
||||
: alloc-fastcall-param ( rep -- n reg-class rep )
|
||||
[ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;
|
||||
|
||||
:: alloc-parameter ( rep abi -- reg rep )
|
||||
rep dup reg-class-of abi reg-class-full?
|
||||
[ alloc-stack-param ] [ alloc-fastcall-param ] if
|
||||
[ abi param-reg ] dip ;
|
||||
|
||||
: reset-fastcall-counts ( -- )
|
||||
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
|
||||
|
||||
: with-param-regs ( quot -- )
|
||||
#! In quot you can call alloc-parameter
|
||||
[ reset-fastcall-counts call ] with-scope ; inline
|
||||
|
||||
:: move-parameters ( params word -- )
|
||||
#! Moves values from C stack to registers (if word is
|
||||
#! ##load-param-reg) and registers to C stack (if word is
|
||||
#! ##save-param-reg).
|
||||
0 params alien-parameters flatten-c-types [
|
||||
[ params abi>> alloc-parameter word execute( offset reg rep -- ) ]
|
||||
[ rep-size cell align + ]
|
||||
2bi
|
||||
] each drop ; inline
|
||||
|
||||
: parameter-offsets ( types -- offsets )
|
||||
0 [ stack-size + ] accumulate nip ;
|
||||
|
||||
: prepare-parameters ( parameters -- offsets types indices )
|
||||
[ length iota <reversed> ] [ parameter-offsets ] [ ] tri ;
|
||||
|
||||
GENERIC: unbox-parameter ( src n c-type -- )
|
||||
|
||||
M: c-type unbox-parameter
|
||||
[ rep>> ] [ unboxer>> ] bi ##unbox ;
|
||||
|
||||
M: long-long-type unbox-parameter
|
||||
unboxer>> ##unbox-long-long ;
|
||||
|
||||
M: struct-c-type unbox-parameter
|
||||
[ [ ^^unbox-any-c-ptr ] 2dip ##unbox-large-struct ]
|
||||
[ base-type unbox-parameter ]
|
||||
if-value-struct ;
|
||||
|
||||
: unbox-parameters ( offset node -- )
|
||||
parameters>> swap
|
||||
'[
|
||||
prepare-parameters
|
||||
: unbox-parameters ( parameters -- vregs )
|
||||
[
|
||||
[ length iota <reversed> ] keep
|
||||
[
|
||||
[ <ds-loc> ^^peek ] [ _ + ] [ base-type ] tri*
|
||||
[ <ds-loc> ^^peek ] [ base-type ] bi*
|
||||
unbox-parameter
|
||||
] 3each
|
||||
] 2map concat
|
||||
]
|
||||
[ length neg ##inc-d ]
|
||||
bi ;
|
||||
[ length neg ##inc-d ] bi ;
|
||||
|
||||
: prepare-box-struct ( node -- offset )
|
||||
: 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.
|
||||
return>> large-struct?
|
||||
[ ##prepare-box-struct cell ] [ 0 ] if ;
|
||||
large-struct? [
|
||||
^^prepare-struct-area int-rep struct-return-on-stack?
|
||||
3array prefix
|
||||
] when ;
|
||||
|
||||
: objects>registers ( params -- )
|
||||
#! Generate code for unboxing a list of C types, then
|
||||
#! generate code for moving these parameters to registers on
|
||||
#! architectures where parameters are passed in registers.
|
||||
: (objects>registers) ( vregs -- )
|
||||
! Place ##store-stack-param instructions first. This ensures
|
||||
! that no registers are used after the ##store-reg-param
|
||||
! instructions.
|
||||
[
|
||||
[ prepare-box-struct ] keep
|
||||
[ unbox-parameters ] keep
|
||||
\ ##load-param-reg move-parameters
|
||||
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@ ;
|
||||
|
||||
: objects>registers ( params -- stack-size )
|
||||
[ abi>> ] [ parameters>> ] [ return>> ] tri
|
||||
'[
|
||||
_ unbox-parameters
|
||||
_ prepare-struct-area
|
||||
(objects>registers)
|
||||
stack-params get
|
||||
] with-param-regs ;
|
||||
|
||||
GENERIC: box-return ( c-type -- dst )
|
||||
|
|
@ -127,7 +92,8 @@ M: long-long-type box-return
|
|||
[ f ] dip boxer>> ^^box-long-long ;
|
||||
|
||||
M: struct-c-type box-return
|
||||
[ ^^box-small-struct ] [ ^^box-large-struct ] if-small-struct ;
|
||||
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 ;
|
||||
|
|
@ -159,63 +125,66 @@ M: array dlsym-valid? '[ _ dlsym ] any? ;
|
|||
[ library>> load-library ]
|
||||
bi 2dup check-dlsym ;
|
||||
|
||||
: return-size ( ctype -- n )
|
||||
: return-size ( c-type -- n )
|
||||
#! Amount of space we reserve for a return value.
|
||||
{
|
||||
{ [ dup c-struct? not ] [ drop 0 ] }
|
||||
{ [ dup void? ] [ drop 0 ] }
|
||||
{ [ dup base-type struct-c-type? not ] [ drop 0 ] }
|
||||
{ [ dup large-struct? not ] [ drop 2 cells ] }
|
||||
[ heap-size ]
|
||||
} cond ;
|
||||
|
||||
: <alien-stack-frame> ( params -- stack-frame )
|
||||
stack-frame new
|
||||
swap
|
||||
[ return>> return-size >>return ]
|
||||
[ alien-parameters [ stack-size ] map-sum >>params ] bi
|
||||
t >>calls-vm? ;
|
||||
|
||||
: alien-node-height ( params -- )
|
||||
[ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
|
||||
|
||||
: emit-alien-node ( node quot -- )
|
||||
: emit-alien-block ( node quot: ( params -- ) -- )
|
||||
'[
|
||||
make-kill-block
|
||||
params>>
|
||||
[ <alien-stack-frame> ##stack-frame ]
|
||||
_
|
||||
[ alien-node-height ]
|
||||
tri
|
||||
_ [ 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
|
||||
[
|
||||
! Unbox parameters
|
||||
dup objects>registers
|
||||
! Call function
|
||||
dup alien-invoke-dlsym ##alien-invoke
|
||||
! Box return value
|
||||
dup ##cleanup
|
||||
box-return*
|
||||
] emit-alien-node ;
|
||||
|
||||
M: #alien-indirect emit-node
|
||||
[
|
||||
D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr
|
||||
{
|
||||
[ drop objects>registers ]
|
||||
[ nip ##alien-indirect ]
|
||||
[ drop ##cleanup ]
|
||||
[ drop box-return* ]
|
||||
} 2cleave
|
||||
] emit-alien-node ;
|
||||
[ objects>registers ]
|
||||
[ 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
|
||||
{
|
||||
[ objects>registers ]
|
||||
[ drop src ##alien-indirect ]
|
||||
[ emit-stack-frame ]
|
||||
[ box-return* ]
|
||||
} cleave
|
||||
] emit-alien-block ;
|
||||
|
||||
M: #alien-assembly emit-node
|
||||
[
|
||||
[ objects>registers ]
|
||||
[ quot>> ##alien-assembly ]
|
||||
[ box-return* ]
|
||||
tri
|
||||
] emit-alien-node ;
|
||||
{
|
||||
[ objects>registers ]
|
||||
[ quot>> ##alien-assembly ]
|
||||
[ emit-stack-frame ]
|
||||
[ box-return* ]
|
||||
} cleave
|
||||
] emit-alien-block ;
|
||||
|
||||
GENERIC: box-parameter ( n c-type -- dst )
|
||||
|
||||
|
|
@ -225,9 +194,22 @@ M: c-type box-parameter
|
|||
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 ]
|
||||
|
|
@ -239,10 +221,45 @@ M: struct-c-type box-parameter
|
|||
] 3each
|
||||
] bi ;
|
||||
|
||||
: registers>objects ( node -- )
|
||||
:: alloc-parameter ( rep -- reg rep )
|
||||
rep dup reg-class-of reg-class-full?
|
||||
[ alloc-stack-param stack-params ] [ [ next-reg-param ] keep ] if ;
|
||||
|
||||
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 \ ##save-param-reg move-parameters
|
||||
dup abi>> [
|
||||
dup (registers>objects)
|
||||
##begin-callback
|
||||
next-vreg next-vreg ##restore-context
|
||||
box-parameters
|
||||
|
|
@ -267,30 +284,52 @@ M: struct-c-type box-parameter
|
|||
GENERIC: unbox-return ( src c-type -- )
|
||||
|
||||
M: c-type unbox-return
|
||||
[ f ] dip [ rep>> ] [ unboxer>> ] bi ##unbox ;
|
||||
unbox first first2 ##store-return ;
|
||||
|
||||
M: long-long-type unbox-return
|
||||
[ f ] dip unboxer>> ##unbox-long-long ;
|
||||
unbox first2 [ first ] bi@ ##store-long-long-return ;
|
||||
|
||||
M: struct-c-type unbox-return
|
||||
[ ^^unbox-any-c-ptr ] dip
|
||||
[ ##unbox-small-struct ] [ ##unbox-large-struct ] if-small-struct ;
|
||||
[ ^^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
|
||||
stack-params get
|
||||
] with-param-regs ;
|
||||
|
||||
: callback-stack-cleanup ( params -- )
|
||||
[ xt>> ] [ [ stack-args-size ] [ return>> ] [ abi>> ] tri stack-cleanup ] bi
|
||||
"stack-cleanup" set-word-prop ;
|
||||
|
||||
M: #alien-callback emit-node
|
||||
dup params>> xt>> dup
|
||||
[
|
||||
##prologue
|
||||
[
|
||||
[ registers>objects ]
|
||||
[ wrap-callback-quot ##alien-callback ]
|
||||
[
|
||||
alien-return [ ##end-callback ] [
|
||||
[ D 0 ^^peek ] dip
|
||||
##end-callback
|
||||
base-type unbox-return
|
||||
] if-void
|
||||
] tri
|
||||
] emit-alien-node
|
||||
{
|
||||
[ registers>objects ]
|
||||
[ emit-callback-stack-frame ]
|
||||
[ callback-stack-cleanup ]
|
||||
[ wrap-callback-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
|
||||
]
|
||||
} cleave
|
||||
] emit-alien-block
|
||||
##epilogue
|
||||
##return
|
||||
] with-cfg-builder ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,49 @@
|
|||
! 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 ;
|
||||
IN: compiler.cfg.builder.alien.params
|
||||
|
||||
: alloc-stack-param ( rep -- n )
|
||||
stack-params get
|
||||
[ rep-size cell align stack-params +@ ] dip ;
|
||||
|
||||
: ?dummy-stack-params ( rep -- )
|
||||
dummy-stack-params? [ alloc-stack-param drop ] [ drop ] if ;
|
||||
|
||||
: ?dummy-int-params ( rep -- )
|
||||
dummy-int-params? [
|
||||
rep-size cell /i 1 max
|
||||
[ int-regs get [ pop* ] unless-empty ] times
|
||||
] [ drop ] if ;
|
||||
|
||||
: ?dummy-fp-params ( rep -- )
|
||||
drop dummy-fp-params? [ float-regs get [ pop* ] unless-empty ] when ;
|
||||
|
||||
GENERIC: next-reg-param ( rep -- reg )
|
||||
|
||||
M: int-rep next-reg-param
|
||||
[ ?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 ;
|
||||
|
||||
M: double-rep next-reg-param
|
||||
[ ?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? ;
|
||||
|
||||
: init-reg-class ( abi reg-class -- )
|
||||
[ swap param-regs <reversed> >vector ] keep set ;
|
||||
|
||||
: with-param-regs ( abi quot -- )
|
||||
'[
|
||||
[ int-regs init-reg-class ]
|
||||
[ float-regs init-reg-class ] bi
|
||||
0 stack-params set
|
||||
@
|
||||
] with-scope ; inline
|
||||
|
|
@ -19,8 +19,7 @@ compiler.cfg.instructions
|
|||
compiler.cfg.predecessors
|
||||
compiler.cfg.builder.blocks
|
||||
compiler.cfg.stacks
|
||||
compiler.cfg.stacks.local
|
||||
compiler.alien ;
|
||||
compiler.cfg.stacks.local ;
|
||||
IN: compiler.cfg.builder
|
||||
|
||||
! Convert tree SSA IR to CFG IR. The result is not in SSA form; this is
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ V{ } clone insn-classes set-global
|
|||
|
||||
: new-insn ( ... class -- insn ) f swap boa ; inline
|
||||
|
||||
! Virtual CPU instructions, used by CFG and machine IRs
|
||||
! Virtual CPU instructions, used by CFG IR
|
||||
TUPLE: insn ;
|
||||
|
||||
! Instructions which are referentially transparent; used for
|
||||
|
|
@ -364,12 +364,6 @@ use: src1
|
|||
temp: temp/int-rep
|
||||
literal: rep vcc ;
|
||||
|
||||
INSN: _test-vector-branch
|
||||
literal: label
|
||||
use: src1
|
||||
temp: temp/int-rep
|
||||
literal: rep vcc ;
|
||||
|
||||
PURE-INSN: ##add-vector
|
||||
def: dst
|
||||
use: src1 src2
|
||||
|
|
@ -612,6 +606,33 @@ literal: offset ;
|
|||
INSN: ##stack-frame
|
||||
literal: stack-frame ;
|
||||
|
||||
INSN: ##unbox
|
||||
def: dst
|
||||
use: src/tagged-rep
|
||||
literal: unboxer rep ;
|
||||
|
||||
INSN: ##store-reg-param
|
||||
use: src
|
||||
literal: reg rep ;
|
||||
|
||||
INSN: ##store-stack-param
|
||||
use: src
|
||||
literal: n rep ;
|
||||
|
||||
INSN: ##store-return
|
||||
use: src
|
||||
literal: rep ;
|
||||
|
||||
INSN: ##store-struct-return
|
||||
use: src/int-rep
|
||||
literal: c-type ;
|
||||
|
||||
INSN: ##store-long-long-return
|
||||
use: src1/int-rep src2/int-rep ;
|
||||
|
||||
INSN: ##prepare-struct-area
|
||||
def: dst/int-rep ;
|
||||
|
||||
INSN: ##box
|
||||
def: dst/tagged-rep
|
||||
literal: n rep boxer ;
|
||||
|
|
@ -628,32 +649,11 @@ INSN: ##box-large-struct
|
|||
def: dst/tagged-rep
|
||||
literal: n c-type ;
|
||||
|
||||
INSN: ##unbox
|
||||
use: src/tagged-rep
|
||||
literal: n rep unboxer ;
|
||||
|
||||
INSN: ##unbox-long-long
|
||||
use: src/tagged-rep
|
||||
literal: n unboxer ;
|
||||
|
||||
INSN: ##unbox-large-struct
|
||||
use: src/int-rep
|
||||
literal: n c-type ;
|
||||
|
||||
INSN: ##unbox-small-struct
|
||||
use: src/int-rep
|
||||
literal: c-type ;
|
||||
|
||||
INSN: ##prepare-box-struct ;
|
||||
|
||||
INSN: ##load-param-reg
|
||||
literal: offset reg rep ;
|
||||
|
||||
INSN: ##alien-invoke
|
||||
literal: symbols dll ;
|
||||
|
||||
INSN: ##cleanup
|
||||
literal: params ;
|
||||
literal: n ;
|
||||
|
||||
INSN: ##alien-indirect
|
||||
use: src/int-rep ;
|
||||
|
|
@ -815,11 +815,10 @@ UNION: clobber-insn
|
|||
##box-small-struct
|
||||
##box-large-struct
|
||||
##unbox
|
||||
##unbox-long-long
|
||||
##unbox-large-struct
|
||||
##unbox-small-struct
|
||||
##prepare-box-struct
|
||||
##load-param-reg
|
||||
##store-reg-param
|
||||
##store-return
|
||||
##store-struct-return
|
||||
##store-long-long-return
|
||||
##alien-invoke
|
||||
##alien-indirect
|
||||
##alien-assembly
|
||||
|
|
|
|||
|
|
@ -1,7 +1,9 @@
|
|||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs heaps kernel namespaces sequences fry math
|
||||
math.order combinators arrays sorting compiler.utilities locals
|
||||
USING: accessors assocs binary-search combinators
|
||||
combinators.short-circuit heaps kernel namespaces
|
||||
sequences fry locals math math.order arrays sorting
|
||||
compiler.utilities
|
||||
compiler.cfg.linear-scan.live-intervals
|
||||
compiler.cfg.linear-scan.allocation.spilling
|
||||
compiler.cfg.linear-scan.allocation.splitting
|
||||
|
|
@ -34,15 +36,15 @@ IN: compiler.cfg.linear-scan.allocation
|
|||
[ drop assign-blocked-register ]
|
||||
} cond ;
|
||||
|
||||
: spill-at-sync-point ( live-interval n -- ? )
|
||||
: spill-at-sync-point ( n live-interval -- ? )
|
||||
! If the live interval has a definition at 'n', don't spill
|
||||
2dup [ uses>> ] dip
|
||||
'[ [ def-rep>> ] [ n>> _ = ] bi and ] any?
|
||||
[ 2drop t ] [ spill f ] if ;
|
||||
2dup find-use
|
||||
{ [ ] [ def-rep>> ] } 1&&
|
||||
[ 2drop t ] [ swap spill f ] if ;
|
||||
|
||||
: handle-sync-point ( n -- )
|
||||
[ active-intervals get values ] dip
|
||||
'[ [ _ spill-at-sync-point ] filter! drop ] each ;
|
||||
active-intervals get values
|
||||
[ [ spill-at-sync-point ] with filter! drop ] with each ;
|
||||
|
||||
:: handle-progress ( n sync? -- )
|
||||
n {
|
||||
|
|
@ -69,11 +71,7 @@ M: sync-point handle ( sync-point -- )
|
|||
} cond ;
|
||||
|
||||
: (allocate-registers) ( -- )
|
||||
! If a live interval begins at the same location as a sync point,
|
||||
! process the sync point before the live interval. This ensures that the
|
||||
! return value of C function calls doesn't get spilled and reloaded
|
||||
! unnecessarily.
|
||||
unhandled-sync-points get unhandled-intervals get smallest-heap
|
||||
unhandled-intervals get unhandled-sync-points get smallest-heap
|
||||
dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
|
||||
|
||||
: finish-allocation ( -- )
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@ ERROR: splitting-atomic-interval ;
|
|||
: check-split ( live-interval n -- )
|
||||
check-allocation? get [
|
||||
[ [ start>> ] dip > [ splitting-too-early ] when ]
|
||||
[ [ end>> ] dip <= [ splitting-too-late ] when ]
|
||||
[ [ end>> ] dip < [ splitting-too-late ] when ]
|
||||
[ drop [ end>> ] [ start>> ] bi = [ splitting-atomic-interval ] when ]
|
||||
2tri
|
||||
] [ 2drop ] if ; inline
|
||||
|
|
|
|||
|
|
@ -145,34 +145,24 @@ H{
|
|||
{ vreg 3 }
|
||||
{ reg-class float-regs }
|
||||
{ start 0 }
|
||||
{ end 1 }
|
||||
{ uses V{ T{ vreg-use f 0 float-rep f } } }
|
||||
{ ranges V{ T{ live-range f 0 1 } } }
|
||||
{ end 2 }
|
||||
{ uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 1 f float-rep } } }
|
||||
{ ranges V{ T{ live-range f 0 2 } } }
|
||||
{ spill-to T{ spill-slot f 8 } }
|
||||
{ spill-rep float-rep }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg 3 }
|
||||
{ reg-class float-regs }
|
||||
{ start 20 }
|
||||
{ end 30 }
|
||||
{ uses V{ T{ vreg-use f 20 f float-rep } T{ vreg-use f 30 f float-rep } } }
|
||||
{ ranges V{ T{ live-range f 20 30 } } }
|
||||
{ reload-from T{ spill-slot f 8 } }
|
||||
{ reload-rep float-rep }
|
||||
}
|
||||
f
|
||||
] [
|
||||
T{ live-interval
|
||||
{ vreg 3 }
|
||||
{ reg-class float-regs }
|
||||
{ start 0 }
|
||||
{ end 30 }
|
||||
{ uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 20 f float-rep } T{ vreg-use f 30 f float-rep } } }
|
||||
{ ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } }
|
||||
} 10 split-for-spill
|
||||
{ end 5 }
|
||||
{ uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 1 f float-rep } T{ vreg-use f 5 f float-rep } } }
|
||||
{ ranges V{ T{ live-range f 0 5 } } }
|
||||
} 5 split-for-spill
|
||||
] unit-test
|
||||
|
||||
! Don't insert reload if first usage is a def
|
||||
[
|
||||
T{ live-interval
|
||||
{ vreg 4 }
|
||||
|
|
@ -189,12 +179,45 @@ H{
|
|||
{ reg-class float-regs }
|
||||
{ start 20 }
|
||||
{ end 30 }
|
||||
{ uses V{ T{ vreg-use f 20 f float-rep } T{ vreg-use f 30 f float-rep } } }
|
||||
{ ranges V{ T{ live-range f 20 30 } } }
|
||||
{ reload-from T{ spill-slot f 12 } }
|
||||
{ reload-rep float-rep }
|
||||
}
|
||||
] [
|
||||
T{ live-interval
|
||||
{ vreg 4 }
|
||||
{ reg-class float-regs }
|
||||
{ start 0 }
|
||||
{ end 30 }
|
||||
{ uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 20 f float-rep } T{ vreg-use f 30 f float-rep } } }
|
||||
{ ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } }
|
||||
} 10 split-for-spill
|
||||
] unit-test
|
||||
|
||||
! Don't insert reload if first usage is a def
|
||||
[
|
||||
T{ live-interval
|
||||
{ vreg 5 }
|
||||
{ reg-class float-regs }
|
||||
{ start 0 }
|
||||
{ end 1 }
|
||||
{ uses V{ T{ vreg-use f 0 float-rep f } } }
|
||||
{ ranges V{ T{ live-range f 0 1 } } }
|
||||
{ spill-to T{ spill-slot f 16 } }
|
||||
{ spill-rep float-rep }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg 5 }
|
||||
{ reg-class float-regs }
|
||||
{ start 20 }
|
||||
{ end 30 }
|
||||
{ uses V{ T{ vreg-use f 20 float-rep f } T{ vreg-use f 30 f float-rep } } }
|
||||
{ ranges V{ T{ live-range f 20 30 } } }
|
||||
}
|
||||
] [
|
||||
T{ live-interval
|
||||
{ vreg 4 }
|
||||
{ vreg 5 }
|
||||
{ reg-class float-regs }
|
||||
{ start 0 }
|
||||
{ end 30 }
|
||||
|
|
@ -206,28 +229,28 @@ H{
|
|||
! Multiple representations
|
||||
[
|
||||
T{ live-interval
|
||||
{ vreg 5 }
|
||||
{ vreg 6 }
|
||||
{ reg-class float-regs }
|
||||
{ start 0 }
|
||||
{ end 11 }
|
||||
{ uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 10 double-rep float-rep } } }
|
||||
{ ranges V{ T{ live-range f 0 11 } } }
|
||||
{ spill-to T{ spill-slot f 16 } }
|
||||
{ spill-to T{ spill-slot f 24 } }
|
||||
{ spill-rep double-rep }
|
||||
}
|
||||
T{ live-interval
|
||||
{ vreg 5 }
|
||||
{ vreg 6 }
|
||||
{ reg-class float-regs }
|
||||
{ start 20 }
|
||||
{ end 20 }
|
||||
{ uses V{ T{ vreg-use f 20 f double-rep } } }
|
||||
{ ranges V{ T{ live-range f 20 20 } } }
|
||||
{ reload-from T{ spill-slot f 16 } }
|
||||
{ reload-from T{ spill-slot f 24 } }
|
||||
{ reload-rep double-rep }
|
||||
}
|
||||
] [
|
||||
T{ live-interval
|
||||
{ vreg 5 }
|
||||
{ vreg 6 }
|
||||
{ reg-class float-regs }
|
||||
{ start 0 }
|
||||
{ end 20 }
|
||||
|
|
|
|||
|
|
@ -54,6 +54,10 @@ M: live-interval covers? ( insn# live-interval -- ? )
|
|||
covers?
|
||||
] if ;
|
||||
|
||||
:: find-use ( insn# live-interval -- vreg-use )
|
||||
insn# live-interval uses>> [ n>> <=> ] with search nip
|
||||
dup [ dup n>> insn# = [ drop f ] unless ] when ;
|
||||
|
||||
: add-new-range ( from to live-interval -- )
|
||||
[ <live-range> ] dip ranges>> push ;
|
||||
|
||||
|
|
|
|||
|
|
@ -276,20 +276,21 @@ CONDITIONAL: ##fixnum-sub %fixnum-sub
|
|||
CONDITIONAL: ##fixnum-mul %fixnum-mul
|
||||
|
||||
! FFI
|
||||
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: ##box %box
|
||||
CODEGEN: ##box-long-long %box-long-long
|
||||
CODEGEN: ##box-large-struct %box-large-struct
|
||||
CODEGEN: ##box-small-struct %box-small-struct
|
||||
CODEGEN: ##unbox %unbox
|
||||
CODEGEN: ##unbox-long-long %unbox-long-long
|
||||
CODEGEN: ##unbox-large-struct %unbox-large-struct
|
||||
CODEGEN: ##unbox-small-struct %unbox-small-struct
|
||||
CODEGEN: ##prepare-box-struct %prepare-box-struct
|
||||
CODEGEN: ##load-param-reg %load-param-reg
|
||||
CODEGEN: ##save-param-reg %save-param-reg
|
||||
CODEGEN: ##alien-invoke %alien-invoke
|
||||
CODEGEN: ##cleanup %cleanup
|
||||
CODEGEN: ##alien-indirect %alien-indirect
|
||||
CODEGEN: ##save-param-reg %save-param-reg
|
||||
CODEGEN: ##begin-callback %begin-callback
|
||||
CODEGEN: ##alien-callback %alien-callback
|
||||
CODEGEN: ##end-callback %end-callback
|
||||
|
|
|
|||
|
|
@ -472,3 +472,10 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-
|
|||
] when ;
|
||||
|
||||
[ ] [ 2000 [ "hello" clone dup gc-root-messup first eq? t assert= ] times ] unit-test
|
||||
|
||||
! Alias analysis bug
|
||||
[ t ] [
|
||||
[
|
||||
10 10 <byte-array> [ <displaced-alien> underlying>> ] keep eq?
|
||||
] compile-call
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -272,6 +272,11 @@ generic-comparison-ops [
|
|||
2drop alien \ f class-or <class-info>
|
||||
] "outputs" set-word-prop
|
||||
|
||||
\ <displaced-alien> [
|
||||
[ interval>> 0 swap interval-contains? ] dip
|
||||
class>> alien class-or alien ? <class-info>
|
||||
] "outputs" set-word-prop
|
||||
|
||||
{ <tuple> <tuple-boa> } [
|
||||
[
|
||||
literal>> dup array? [ first ] [ drop tuple ] if <class-info>
|
||||
|
|
|
|||
|
|
@ -976,3 +976,22 @@ M: tuple-with-read-only-slot clone
|
|||
! Should actually be 0 23 2^ 1 - [a,b]
|
||||
[ string-nth ] final-info first interval>> 0 23 2^ [a,b] =
|
||||
] unit-test
|
||||
|
||||
! Non-zero displacement for <displaced-alien> restricts the output type
|
||||
[ t ] [
|
||||
[ { byte-array } declare <displaced-alien> ] final-classes
|
||||
first byte-array alien class-or class=
|
||||
] unit-test
|
||||
|
||||
[ V{ alien } ] [
|
||||
[ { alien } declare <displaced-alien> ] final-classes
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { POSTPONE: f } declare <displaced-alien> ] final-classes
|
||||
first \ f alien class-or class=
|
||||
] unit-test
|
||||
|
||||
[ V{ alien } ] [
|
||||
[ { byte-array } declare [ 10 bitand 2 + ] dip <displaced-alien> ] final-classes
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -534,10 +534,6 @@ M: object immediate-comparand? ( n -- ? )
|
|||
: immediate-shift-count? ( n -- ? )
|
||||
0 cell-bits 1 - between? ;
|
||||
|
||||
! What c-type describes the implicit struct return pointer for
|
||||
! large structs?
|
||||
HOOK: struct-return-pointer-type cpu ( -- c-type )
|
||||
|
||||
! Is this structure small enough to be returned in registers?
|
||||
HOOK: return-struct-in-registers? cpu ( c-type -- ? )
|
||||
|
||||
|
|
@ -553,15 +549,30 @@ HOOK: dummy-int-params? cpu ( -- ? )
|
|||
! If t, all int parameters are shadowed by dummy FP parameters
|
||||
HOOK: dummy-fp-params? cpu ( -- ? )
|
||||
|
||||
! If t, long longs are never passed in param regs
|
||||
HOOK: long-long-on-stack? cpu ( -- ? )
|
||||
|
||||
! If t, floats are never passed in param regs
|
||||
HOOK: float-on-stack? cpu ( -- ? )
|
||||
|
||||
! If t, the struct return pointer is never passed in a param reg
|
||||
HOOK: struct-return-on-stack? cpu ( -- ? )
|
||||
|
||||
! Call a function to convert a tagged pointer into a value that
|
||||
! can be passed to a C function, or returned from a callback
|
||||
HOOK: %unbox cpu ( src n rep func -- )
|
||||
HOOK: %unbox cpu ( dst src func rep -- )
|
||||
|
||||
HOOK: %unbox-long-long cpu ( src n func -- )
|
||||
HOOK: %store-reg-param cpu ( src reg rep -- )
|
||||
|
||||
HOOK: %unbox-small-struct cpu ( src c-type -- )
|
||||
HOOK: %store-stack-param cpu ( src n rep -- )
|
||||
|
||||
HOOK: %unbox-large-struct cpu ( src n c-type -- )
|
||||
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 -- )
|
||||
|
||||
! Call a function to convert a value into a tagged pointer,
|
||||
! possibly allocating a bignum, float, or alien instance,
|
||||
|
|
@ -570,25 +581,21 @@ HOOK: %box cpu ( dst n rep func -- )
|
|||
|
||||
HOOK: %box-long-long cpu ( dst n func -- )
|
||||
|
||||
HOOK: %prepare-box-struct cpu ( -- )
|
||||
|
||||
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: %load-param-reg cpu ( stack reg rep -- )
|
||||
|
||||
HOOK: %restore-context cpu ( temp1 temp2 -- )
|
||||
|
||||
HOOK: %save-context cpu ( temp1 temp2 -- )
|
||||
|
||||
HOOK: %alien-invoke cpu ( function library -- )
|
||||
|
||||
HOOK: %cleanup cpu ( params -- )
|
||||
HOOK: %cleanup cpu ( n -- )
|
||||
|
||||
M: object %cleanup ( params -- ) drop ;
|
||||
M: object %cleanup ( n -- ) drop ;
|
||||
|
||||
HOOK: %alien-indirect cpu ( src -- )
|
||||
|
||||
|
|
@ -598,6 +605,6 @@ HOOK: %alien-callback cpu ( quot -- )
|
|||
|
||||
HOOK: %end-callback cpu ( -- )
|
||||
|
||||
HOOK: stack-cleanup cpu ( params -- n )
|
||||
HOOK: stack-cleanup cpu ( stack-size return abi -- n )
|
||||
|
||||
M: object stack-cleanup drop 0 ;
|
||||
M: object stack-cleanup 3drop 0 ;
|
||||
|
|
|
|||
|
|
@ -3,8 +3,8 @@
|
|||
USING: accessors assocs sequences kernel combinators
|
||||
classes.algebra byte-arrays make math math.order math.ranges
|
||||
system namespaces locals layouts words alien alien.accessors
|
||||
alien.c-types alien.complex alien.data literals cpu.architecture
|
||||
cpu.ppc.assembler cpu.ppc.assembler.backend
|
||||
alien.c-types alien.complex alien.data alien.libraries
|
||||
literals cpu.architecture cpu.ppc.assembler cpu.ppc.assembler.backend
|
||||
compiler.cfg.registers compiler.cfg.instructions
|
||||
compiler.cfg.comparisons compiler.codegen.fixup
|
||||
compiler.cfg.intrinsics compiler.cfg.stack-frame
|
||||
|
|
@ -681,13 +681,13 @@ GENERIC: load-param ( reg src -- )
|
|||
|
||||
M: integer load-param int-rep %copy ;
|
||||
|
||||
M: spill-slot load-param n>> spill@ LWZ ;
|
||||
M: spill-slot load-param [ 1 ] dip n>> spill@ LWZ ;
|
||||
|
||||
GENERIC: store-param ( reg dst -- )
|
||||
|
||||
M: integer store-param swap int-rep %copy ;
|
||||
|
||||
M: spill-slot store-param n>> spill@ STW ;
|
||||
M: spill-slot store-param [ 1 ] dip n>> spill@ STW ;
|
||||
|
||||
:: call-unbox-func ( src func -- )
|
||||
3 src load-param
|
||||
|
|
@ -710,7 +710,7 @@ M:: ppc %unbox-long-long ( src n func -- )
|
|||
M:: ppc %unbox-large-struct ( src n c-type -- )
|
||||
4 src load-param
|
||||
3 1 n local@ ADDI
|
||||
heap-size 5 LI
|
||||
c-type heap-size 5 LI
|
||||
"memcpy" "libc" load-library %alien-invoke ;
|
||||
|
||||
M:: ppc %box ( dst n rep func -- )
|
||||
|
|
@ -724,6 +724,7 @@ M:: ppc %box-long-long ( dst n func -- )
|
|||
3 1 n local@ LWZ
|
||||
4 1 n cell + local@ LWZ
|
||||
] when
|
||||
5 %load-vm-addr
|
||||
func f %alien-invoke
|
||||
3 dst store-param ;
|
||||
|
||||
|
|
@ -768,8 +769,6 @@ M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
|
|||
|
||||
M: ppc immediate-store? drop f ;
|
||||
|
||||
M: ppc struct-return-pointer-type void* ;
|
||||
|
||||
M: ppc return-struct-in-registers? ( c-type -- ? )
|
||||
c-type return-in-registers?>> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,13 +3,10 @@
|
|||
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
|
||||
command-line make words compiler compiler.units
|
||||
compiler.constants compiler.alien compiler.codegen
|
||||
compiler.codegen.fixup compiler.cfg.instructions
|
||||
compiler.cfg.builder compiler.cfg.builder.alien
|
||||
compiler.cfg.intrinsics compiler.cfg.stack-frame
|
||||
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
|
||||
cpu.architecture vm ;
|
||||
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 ;
|
||||
FROM: layouts => cell ;
|
||||
IN: cpu.x86.32
|
||||
|
||||
|
|
@ -95,17 +92,14 @@ M: x86.32 return-struct-in-registers? ( c-type -- ? )
|
|||
os { linux netbsd solaris } member? not
|
||||
and or ;
|
||||
|
||||
: struct-return@ ( n -- operand )
|
||||
[ next-stack@ ] [ stack-frame get params>> local@ ] if* ;
|
||||
|
||||
! On x86, parameters are usually never passed in registers, except with Microsoft's
|
||||
! "thiscall" and "fastcall" abis
|
||||
! 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 } ] }
|
||||
{ thiscall [ { ECX } ] }
|
||||
{ fastcall [ { ECX EDX } ] }
|
||||
[ drop { } ]
|
||||
} case ;
|
||||
|
|
@ -119,11 +113,37 @@ 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 ;
|
||||
|
||||
M: float-rep load-return-reg drop FLDS ;
|
||||
M: float-rep store-return-reg drop FSTPS ;
|
||||
:: 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
|
||||
|
||||
M: double-rep load-return-reg drop FLDL ;
|
||||
M: double-rep store-return-reg drop FSTPL ;
|
||||
:: 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 ;
|
||||
|
||||
M: x86.32 %prologue ( n -- )
|
||||
dup PUSH
|
||||
|
|
@ -133,6 +153,29 @@ M: x86.32 %prologue ( n -- )
|
|||
M: x86.32 %prepare-jump
|
||||
pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
|
||||
|
||||
:: call-unbox-func ( src func -- )
|
||||
EAX src tagged-rep %copy
|
||||
4 save-vm-ptr
|
||||
0 stack@ EAX MOV
|
||||
func f %alien-invoke ;
|
||||
|
||||
M:: x86.32 %unbox ( dst src func rep -- )
|
||||
src func call-unbox-func
|
||||
dst ?spill-slot rep store-return-reg ;
|
||||
|
||||
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
|
||||
{
|
||||
|
|
@ -142,8 +185,6 @@ M: stack-params copy-register*
|
|||
|
||||
M: x86.32 %save-param-reg [ local@ ] 2dip %copy ;
|
||||
|
||||
M: x86.32 %load-param-reg [ swap local@ ] dip %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
|
||||
|
|
@ -172,6 +213,9 @@ M:: x86.32 %box-long-long ( dst n func -- )
|
|||
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
|
||||
|
|
@ -180,12 +224,6 @@ M:: x86.32 %box-large-struct ( dst n c-type -- )
|
|||
"from_value_struct" f %alien-invoke
|
||||
dst EAX tagged-rep %copy ;
|
||||
|
||||
M: x86.32 %prepare-box-struct ( -- )
|
||||
! Compute target address for value struct return
|
||||
EAX f struct-return@ LEA
|
||||
! Store it as the first parameter
|
||||
0 local@ EAX MOV ;
|
||||
|
||||
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
|
||||
|
|
@ -195,46 +233,6 @@ M:: x86.32 %box-small-struct ( dst c-type -- )
|
|||
"from_small_struct" f %alien-invoke
|
||||
dst EAX tagged-rep %copy ;
|
||||
|
||||
:: call-unbox-func ( src func -- )
|
||||
EAX src tagged-rep %copy
|
||||
4 save-vm-ptr
|
||||
0 stack@ EAX MOV
|
||||
func f %alien-invoke ;
|
||||
|
||||
M:: x86.32 %unbox ( src n rep func -- )
|
||||
! If n is f, we're unboxing a return value about to be
|
||||
! returned by the callback. Otherwise, we're unboxing
|
||||
! a parameter to a C function about to be called.
|
||||
src func call-unbox-func
|
||||
! Store the return value on the C stack
|
||||
n [ n local@ rep store-return-reg ] when ;
|
||||
|
||||
M:: x86.32 %unbox-long-long ( src n func -- )
|
||||
src func call-unbox-func
|
||||
! Store the return value on the C stack
|
||||
n [
|
||||
[ local@ EAX MOV ]
|
||||
[ 4 + local@ EDX MOV ] bi
|
||||
] when* ;
|
||||
|
||||
M: x86 %unbox-small-struct ( src size -- )
|
||||
[ [ EAX ] dip int-rep %copy ]
|
||||
[
|
||||
heap-size 4 > [ EDX EAX 4 [+] MOV ] when
|
||||
EAX EAX [] MOV
|
||||
] bi* ;
|
||||
|
||||
M:: x86.32 %unbox-large-struct ( src n c-type -- )
|
||||
EAX src int-rep %copy
|
||||
EDX n local@ LEA
|
||||
8 stack@ c-type heap-size MOV
|
||||
4 stack@ EAX MOV
|
||||
0 stack@ EDX MOV
|
||||
"memcpy" "libc" load-library %alien-invoke ;
|
||||
|
||||
M: x86.32 %alien-indirect ( src -- )
|
||||
?spill-slot CALL ;
|
||||
|
||||
M: x86.32 %begin-callback ( -- )
|
||||
0 save-vm-ptr
|
||||
4 stack@ 0 MOV
|
||||
|
|
@ -277,32 +275,23 @@ M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
|
|||
func "libm" load-library %alien-invoke
|
||||
dst float-function-return ;
|
||||
|
||||
: funny-large-struct-return? ( params -- ? )
|
||||
: funny-large-struct-return? ( return abi -- ? )
|
||||
#! MINGW ABI incompatibility disaster
|
||||
[ return>> large-struct? ]
|
||||
[ abi>> mingw = os windows? not or ]
|
||||
bi and ;
|
||||
[ large-struct? ] [ mingw eq? os windows? not or ] bi* and ;
|
||||
|
||||
: stack-arg-size ( params -- n )
|
||||
dup abi>> '[
|
||||
alien-parameters flatten-c-types
|
||||
[ _ alloc-parameter 2drop ] each
|
||||
stack-params get
|
||||
] with-param-regs ;
|
||||
|
||||
M: x86.32 stack-cleanup ( params -- n )
|
||||
M:: x86.32 stack-cleanup ( stack-size return abi -- n )
|
||||
#! a) Functions which are stdcall/fastcall/thiscall have to
|
||||
#! clean up the caller's stack frame.
|
||||
#! b) Functions returning large structs on MINGW have to
|
||||
#! fix ESP.
|
||||
{
|
||||
{ [ dup abi>> callee-cleanup? ] [ stack-arg-size ] }
|
||||
{ [ dup funny-large-struct-return? ] [ drop 4 ] }
|
||||
[ drop 0 ]
|
||||
{ [ abi callee-cleanup? ] [ stack-size ] }
|
||||
{ [ return abi funny-large-struct-return? ] [ 4 ] }
|
||||
[ 0 ]
|
||||
} cond ;
|
||||
|
||||
M: x86.32 %cleanup ( params -- )
|
||||
stack-cleanup [ ESP swap SUB ] unless-zero ;
|
||||
M: x86.32 %cleanup ( n -- )
|
||||
[ ESP swap SUB ] unless-zero ;
|
||||
|
||||
M:: x86.32 %call-gc ( gc-roots -- )
|
||||
4 save-vm-ptr
|
||||
|
|
@ -315,12 +304,13 @@ M: x86.32 dummy-int-params? f ;
|
|||
|
||||
M: x86.32 dummy-fp-params? f ;
|
||||
|
||||
! Dreadful
|
||||
M: struct-c-type flatten-c-type stack-params (flatten-c-type) ;
|
||||
M: long-long-type flatten-c-type stack-params (flatten-c-type) ;
|
||||
M: c-type flatten-c-type dup rep>> int-rep? int-rep stack-params ? (flatten-c-type) ;
|
||||
M: x86.32 long-long-on-stack? t ;
|
||||
|
||||
M: x86.32 struct-return-pointer-type
|
||||
os linux? void* (stack-value) ? ;
|
||||
M: x86.32 float-on-stack? t ;
|
||||
|
||||
M: x86.32 flatten-struct-type
|
||||
stack-size cell /i { int-rep t } <repetition> ;
|
||||
|
||||
M: x86.32 struct-return-on-stack? os linux? not ;
|
||||
|
||||
check-sse
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel math namespaces make sequences
|
||||
system layouts alien alien.c-types alien.accessors alien.libraries
|
||||
slots splitting assocs combinators locals compiler.constants
|
||||
slots splitting assocs combinators fry locals compiler.constants
|
||||
classes.struct compiler.codegen compiler.codegen.fixup
|
||||
compiler.cfg.instructions compiler.cfg.builder
|
||||
compiler.cfg.intrinsics compiler.cfg.stack-frame
|
||||
|
|
@ -99,6 +99,39 @@ M:: x86.64 %dispatch ( src temp -- )
|
|||
[ (align-code) ]
|
||||
bi ;
|
||||
|
||||
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 ;
|
||||
|
||||
: 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
|
||||
{
|
||||
|
|
@ -108,84 +141,32 @@ M: stack-params copy-register*
|
|||
|
||||
M: x86.64 %save-param-reg [ param@ ] 2dip %copy ;
|
||||
|
||||
M: x86.64 %load-param-reg [ swap param@ ] dip %copy ;
|
||||
|
||||
: with-return-regs ( quot -- )
|
||||
[
|
||||
V{ RDX RAX } clone int-regs set
|
||||
V{ XMM1 XMM0 } clone float-regs set
|
||||
call
|
||||
] with-scope ; inline
|
||||
|
||||
M:: x86.64 %unbox ( src n rep func -- )
|
||||
param-reg-0 src tagged-rep %copy
|
||||
param-reg-1 %mov-vm-ptr
|
||||
! Call the unboxer
|
||||
func f %alien-invoke
|
||||
! Store the return value on the C stack if this is an
|
||||
! alien-invoke, otherwise leave it the return register if
|
||||
! this is the end of alien-callback
|
||||
n [ n rep reg-class-of return-reg rep %save-param-reg ] when ;
|
||||
|
||||
: %unbox-struct-field ( 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 %unbox-small-struct ( src c-type -- )
|
||||
! Move src to R11 so that we don't clobber it.
|
||||
R11 src int-rep %copy
|
||||
[
|
||||
c-type flatten-struct-type
|
||||
[ %unbox-struct-field ] each-index
|
||||
] with-return-regs ;
|
||||
|
||||
M:: x86.64 %unbox-large-struct ( src n c-type -- )
|
||||
param-reg-1 src int-rep %copy
|
||||
param-reg-0 n param@ LEA
|
||||
param-reg-2 c-type heap-size MOV
|
||||
"memcpy" "libc" load-library %alien-invoke ;
|
||||
|
||||
: load-return-value ( rep -- )
|
||||
[ [ 0 ] dip reg-class-of cdecl param-reg ]
|
||||
[ reg-class-of return-reg ]
|
||||
[ ]
|
||||
tri %copy ;
|
||||
|
||||
M:: x86.64 %box ( dst n rep func -- )
|
||||
n [
|
||||
n
|
||||
0 rep reg-class-of cdecl param-reg
|
||||
rep %load-param-reg
|
||||
] [
|
||||
rep load-return-value
|
||||
] if
|
||||
0 rep reg-class-of cdecl param-reg
|
||||
n [ n param@ ] [ rep reg-class-of return-reg ] if 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 ;
|
||||
|
||||
: box-struct-field@ ( i -- operand ) 1 + cells param@ ;
|
||||
: box-struct-component@ ( i -- operand ) 1 + cells param@ ;
|
||||
|
||||
: %box-struct-field ( rep i -- )
|
||||
box-struct-field@ swap reg-class-of {
|
||||
: %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 flatten-struct-type [ %box-struct-field ] each-index
|
||||
param-reg-2 c-type heap-size MOV
|
||||
param-reg-0 0 box-struct-field@ MOV
|
||||
param-reg-1 1 box-struct-field@ MOV
|
||||
param-reg-3 %mov-vm-ptr
|
||||
"from_small_struct" f %alien-invoke
|
||||
dst RAX tagged-rep %copy
|
||||
] with-return-regs ;
|
||||
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 ;
|
||||
|
||||
: struct-return@ ( n -- operand )
|
||||
M: x86.64 struct-return@ ( n -- operand )
|
||||
[ stack-frame get params>> ] unless* param@ ;
|
||||
|
||||
M:: x86.64 %box-large-struct ( dst n c-type -- )
|
||||
|
|
@ -198,20 +179,11 @@ M:: x86.64 %box-large-struct ( dst n c-type -- )
|
|||
"from_value_struct" f %alien-invoke
|
||||
dst RAX tagged-rep %copy ;
|
||||
|
||||
M: x86.64 %prepare-box-struct ( -- )
|
||||
! Compute target address for value struct return
|
||||
RAX f struct-return@ LEA
|
||||
! Store it as the first parameter
|
||||
0 param@ RAX MOV ;
|
||||
|
||||
M: x86.64 %alien-invoke
|
||||
R11 0 MOV
|
||||
rc-absolute-cell rel-dlsym
|
||||
R11 CALL ;
|
||||
|
||||
M: x86.64 %alien-indirect ( src -- )
|
||||
?spill-slot CALL ;
|
||||
|
||||
M: x86.64 %begin-callback ( -- )
|
||||
param-reg-0 %mov-vm-ptr
|
||||
param-reg-1 0 MOV
|
||||
|
|
@ -249,7 +221,11 @@ M:: x86.64 %call-gc ( gc-roots -- )
|
|||
param-reg-1 %mov-vm-ptr
|
||||
"inline_gc" f %alien-invoke ;
|
||||
|
||||
M: x86.64 struct-return-pointer-type void* ;
|
||||
M: x86.64 long-long-on-stack? f ;
|
||||
|
||||
M: x86.64 float-on-stack? f ;
|
||||
|
||||
M: x86.64 struct-return-on-stack? f ;
|
||||
|
||||
! The result of reading 4 bytes from memory is a fixnum on
|
||||
! x86-64.
|
||||
|
|
|
|||
|
|
@ -28,10 +28,11 @@ M: x86.64 reserved-stack-space 0 ;
|
|||
struct-types&offset split-struct [
|
||||
[ c-type c-type-rep reg-class-of ] map
|
||||
int-regs swap member? int-rep double-rep ?
|
||||
f 2array
|
||||
] map ;
|
||||
|
||||
: flatten-large-struct ( c-type -- seq )
|
||||
stack-params (flatten-c-type) ;
|
||||
stack-size cell /i { int-rep t } <repetition> ;
|
||||
|
||||
M: x86.64 flatten-struct-type ( c-type -- seq )
|
||||
dup heap-size 16 >
|
||||
|
|
|
|||
|
|
@ -1443,10 +1443,28 @@ M: x86.64 %scalar>integer ( dst src rep -- )
|
|||
} case ;
|
||||
|
||||
M: x86 %vector>scalar %copy ;
|
||||
|
||||
M: x86 %scalar>vector %copy ;
|
||||
|
||||
M:: x86 %spill ( src rep dst -- ) dst src rep %copy ;
|
||||
M:: x86 %reload ( dst rep src -- ) dst src rep %copy ;
|
||||
M:: x86 %spill ( src rep dst -- )
|
||||
dst src rep %copy ;
|
||||
|
||||
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 ;
|
||||
|
||||
HOOK: struct-return@ cpu ( n -- operand )
|
||||
|
||||
M: x86 %prepare-struct-area ( dst -- )
|
||||
f struct-return@ LEA ;
|
||||
|
||||
M: x86 %alien-indirect ( src -- )
|
||||
?spill-slot CALL ;
|
||||
|
||||
M: x86 %loop-entry 16 alignment [ NOP ] times ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! 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 cpu.architecture fry stack-checker.backend
|
||||
alien.c-types fry stack-checker.backend
|
||||
stack-checker.errors stack-checker.visitor
|
||||
stack-checker.dependencies ;
|
||||
IN: stack-checker.alien
|
||||
|
|
@ -98,11 +98,11 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
|
|||
! Quotation which coerces return value to required type
|
||||
infer-return ;
|
||||
|
||||
: callback-xt ( word return-rewind -- alien )
|
||||
[ callbacks get ] dip '[ _ <callback> ] cache ;
|
||||
: callback-xt ( word -- alien )
|
||||
callbacks get [ dup "stack-cleanup" word-prop <callback> ] cache ;
|
||||
|
||||
: callback-bottom ( params -- )
|
||||
[ xt>> ] [ stack-cleanup ] bi '[ _ _ callback-xt ] infer-quot-here ;
|
||||
xt>> '[ _ callback-xt ] infer-quot-here ;
|
||||
|
||||
: infer-alien-callback ( -- )
|
||||
alien-callback-params new
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
USING: alien.strings continuations io
|
||||
io.encodings.ascii kernel namespaces x11.xlib x11.io
|
||||
vocabs vocabs.loader ;
|
||||
FROM: alien.c-types => c-bool> ;
|
||||
IN: x11
|
||||
|
||||
SYMBOL: dpy
|
||||
|
|
@ -11,7 +12,7 @@ SYMBOL: root
|
|||
|
||||
: init-locale ( -- )
|
||||
LC_ALL "" setlocale [ "setlocale() failed" print flush ] unless
|
||||
XSupportsLocale [ "XSupportsLocale() failed" print flush ] unless ;
|
||||
XSupportsLocale c-bool> [ "XSupportsLocale() failed" print flush ] unless ;
|
||||
|
||||
: flush-dpy ( -- ) dpy get XFlush drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +0,0 @@
|
|||
IN: cuda.constants
|
||||
|
||||
CONSTANT: cuda-shared-size 16384
|
||||
CONSTANT: cuda-warp-size 32
|
||||
|
|
@ -5,9 +5,9 @@ alien.syntax arrays assocs byte-arrays classes.struct
|
|||
combinators continuations cuda.ffi cuda.memory cuda.utils
|
||||
destructors fry init io io.backend io.encodings.string
|
||||
io.encodings.utf8 kernel lexer locals macros math math.parser
|
||||
namespaces nested-comments opengl.gl.extensions parser
|
||||
prettyprint quotations sequences words cuda.libraries ;
|
||||
QUALIFIED-WITH: alien.c-types a
|
||||
namespaces opengl.gl.extensions parser prettyprint quotations
|
||||
sequences words cuda.libraries ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
IN: cuda
|
||||
|
||||
TUPLE: launcher
|
||||
|
|
@ -41,11 +41,11 @@ dim-grid dim-block shared-size stream ;
|
|||
|
||||
: c-type>cuda-setter ( c-type -- n cuda-type )
|
||||
{
|
||||
{ [ dup a:int = ] [ drop 4 [ cuda-int* ] ] }
|
||||
{ [ dup a:uint = ] [ drop 4 [ cuda-int* ] ] }
|
||||
{ [ dup a:float = ] [ drop 4 [ cuda-float* ] ] }
|
||||
{ [ dup a:pointer? ] [ drop 4 [ cuda-int* ] ] }
|
||||
{ [ dup a:void* = ] [ drop 4 [ cuda-int* ] ] }
|
||||
{ [ dup c:int = ] [ drop 4 [ cuda-int* ] ] }
|
||||
{ [ dup c:uint = ] [ drop 4 [ cuda-int* ] ] }
|
||||
{ [ dup c:float = ] [ drop 4 [ cuda-float* ] ] }
|
||||
{ [ dup c:pointer? ] [ drop 4 [ cuda-int* ] ] }
|
||||
{ [ dup c:void* = ] [ drop 4 [ cuda-int* ] ] }
|
||||
} cond ;
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -85,5 +85,5 @@ MACRO: cuda-arguments ( c-types -- quot: ( args... function -- ) )
|
|||
[ run-function-launcher ] 2bi
|
||||
]
|
||||
]
|
||||
[ 2nip \ function-launcher suffix a:void function-effect ]
|
||||
[ 2nip \ function-launcher suffix c:void function-effect ]
|
||||
3bi define-declared ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,13 @@
|
|||
! (c)2010 Joe Groff bsd license
|
||||
USING: cuda.devices tools.test ;
|
||||
IN: cuda.devices.tests
|
||||
|
||||
[ 1 5 100 ] [ 5 20 100 10 (distribute-jobs) ] unit-test
|
||||
[ 2 5 100 ] [ 10 20 100 10 (distribute-jobs) ] unit-test
|
||||
[ 2 5 100 ] [ 10 20 200 5 (distribute-jobs) ] unit-test
|
||||
[ 2 5 100 ] [ 10 20 300 6 (distribute-jobs) ] unit-test
|
||||
[ 2 6 120 ] [ 11 20 300 6 (distribute-jobs) ] unit-test
|
||||
[ 1 10 200 ] [ 10 20 200 10 (distribute-jobs) ] unit-test
|
||||
[ 1 10 0 ] [ 10 0 200 10 (distribute-jobs) ] unit-test
|
||||
[ 2 5 0 ] [ 10 0 200 9 (distribute-jobs) ] unit-test
|
||||
|
||||
|
|
@ -1,17 +1,15 @@
|
|||
! Copyright (C) 2010 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types alien.data alien.strings arrays assocs
|
||||
byte-arrays classes.struct combinators cuda cuda.ffi cuda.utils
|
||||
fry io io.encodings.utf8 kernel math.parser prettyprint
|
||||
sequences ;
|
||||
USING: accessors alien.c-types alien.data alien.strings arrays
|
||||
assocs byte-arrays classes.struct combinators cuda cuda.ffi
|
||||
cuda.syntax cuda.utils fry io io.encodings.utf8 kernel locals
|
||||
math math.order math.parser namespaces prettyprint sequences ;
|
||||
IN: cuda.devices
|
||||
|
||||
: #cuda-devices ( -- n )
|
||||
init-cuda
|
||||
int <c-object> [ cuDeviceGetCount cuda-error ] keep *int ;
|
||||
|
||||
: n>cuda-device ( n -- device )
|
||||
init-cuda
|
||||
[ CUdevice <c-object> ] dip [ cuDeviceGet cuda-error ] 2keep drop *int ;
|
||||
|
||||
: enumerate-cuda-devices ( -- devices )
|
||||
|
|
@ -21,40 +19,33 @@ IN: cuda.devices
|
|||
[ enumerate-cuda-devices ] dip '[ <launcher> _ with-cuda ] each ; inline
|
||||
|
||||
: cuda-device-properties ( n -- properties )
|
||||
init-cuda
|
||||
[ CUdevprop <c-object> ] dip
|
||||
[ cuDeviceGetProperties cuda-error ] 2keep drop
|
||||
CUdevprop memory>struct ;
|
||||
[ CUdevprop <struct> ] dip
|
||||
[ cuDeviceGetProperties cuda-error ] 2keep drop ;
|
||||
|
||||
: cuda-devices ( -- assoc )
|
||||
enumerate-cuda-devices [ dup cuda-device-properties ] { } map>assoc ;
|
||||
|
||||
: cuda-device-name ( n -- string )
|
||||
init-cuda
|
||||
[ 256 [ <byte-array> ] keep ] dip
|
||||
[ cuDeviceGetName cuda-error ]
|
||||
[ 2drop utf8 alien>string ] 3bi ;
|
||||
|
||||
: cuda-device-capability ( n -- pair )
|
||||
init-cuda
|
||||
[ int <c-object> int <c-object> ] dip
|
||||
[ cuDeviceComputeCapability cuda-error ]
|
||||
[ drop [ *int ] bi@ ] 3bi 2array ;
|
||||
|
||||
: cuda-device-memory ( n -- bytes )
|
||||
init-cuda
|
||||
[ uint <c-object> ] dip
|
||||
[ cuDeviceTotalMem cuda-error ]
|
||||
[ drop *uint ] 2bi ;
|
||||
|
||||
: cuda-device-attribute ( attribute n -- n )
|
||||
init-cuda
|
||||
[ int <c-object> ] 2dip
|
||||
[ cuDeviceGetAttribute cuda-error ]
|
||||
[ 2drop *int ] 3bi ;
|
||||
|
||||
: cuda-device. ( n -- )
|
||||
init-cuda
|
||||
{
|
||||
[ "Device: " write number>string print ]
|
||||
[ "Name: " write cuda-device-name print ]
|
||||
|
|
@ -76,3 +67,20 @@ IN: cuda.devices
|
|||
"CUDA Version: " write cuda-version number>string print nl
|
||||
#cuda-devices iota [ nl ] [ cuda-device. ] interleave ;
|
||||
|
||||
: up/i ( x y -- z )
|
||||
[ 1 - + ] keep /i ; inline
|
||||
|
||||
:: (distribute-jobs) ( job-count per-job-shared max-shared-size max-block-size
|
||||
-- grid-size block-size per-block-shared )
|
||||
per-job-shared [ max-block-size ] [ max-shared-size swap /i max-block-size min ] if-zero
|
||||
job-count min :> job-max-block-size
|
||||
job-count job-max-block-size up/i :> grid-size
|
||||
job-count grid-size up/i :> block-size
|
||||
block-size per-job-shared * :> per-block-shared
|
||||
|
||||
grid-size block-size per-block-shared ; inline
|
||||
|
||||
: distribute-jobs ( job-count per-job-shared -- launcher )
|
||||
cuda-device get cuda-device-properties
|
||||
[ sharedMemPerBlock>> ] [ maxThreadsDim>> first ] bi
|
||||
(distribute-jobs) 3<<< ; inline
|
||||
|
|
|
|||
|
|
@ -0,0 +1,292 @@
|
|||
! (c)2010 Joe Groff bsd license
|
||||
USING: accessors alien.c-types classes.struct kernel math ;
|
||||
FROM: alien.c-types => float ;
|
||||
IN: cuda.types
|
||||
|
||||
STRUCT: char1
|
||||
{ x char } ;
|
||||
STRUCT: char2
|
||||
{ x char }
|
||||
{ y char } ;
|
||||
STRUCT: char3
|
||||
{ x char }
|
||||
{ y char }
|
||||
{ z char } ;
|
||||
STRUCT: char4
|
||||
{ x char }
|
||||
{ y char }
|
||||
{ z char }
|
||||
{ w char } ;
|
||||
|
||||
STRUCT: uchar1
|
||||
{ x uchar } ;
|
||||
STRUCT: uchar2
|
||||
{ x uchar }
|
||||
{ y uchar } ;
|
||||
STRUCT: uchar3
|
||||
{ x uchar }
|
||||
{ y uchar }
|
||||
{ z uchar } ;
|
||||
STRUCT: uchar4
|
||||
{ x uchar }
|
||||
{ y uchar }
|
||||
{ z uchar }
|
||||
{ w uchar } ;
|
||||
|
||||
STRUCT: short1
|
||||
{ x short } ;
|
||||
STRUCT: short2
|
||||
{ x short }
|
||||
{ y short } ;
|
||||
STRUCT: short3
|
||||
{ x short }
|
||||
{ y short }
|
||||
{ z short } ;
|
||||
STRUCT: short4
|
||||
{ x short }
|
||||
{ y short }
|
||||
{ z short }
|
||||
{ w short } ;
|
||||
|
||||
STRUCT: ushort1
|
||||
{ x ushort } ;
|
||||
STRUCT: ushort2
|
||||
{ x ushort }
|
||||
{ y ushort } ;
|
||||
STRUCT: ushort3
|
||||
{ x ushort }
|
||||
{ y ushort }
|
||||
{ z ushort } ;
|
||||
STRUCT: ushort4
|
||||
{ x ushort }
|
||||
{ y ushort }
|
||||
{ z ushort }
|
||||
{ w ushort } ;
|
||||
|
||||
STRUCT: int1
|
||||
{ x int } ;
|
||||
STRUCT: int2
|
||||
{ x int }
|
||||
{ y int } ;
|
||||
STRUCT: int3
|
||||
{ x int }
|
||||
{ y int }
|
||||
{ z int } ;
|
||||
STRUCT: int4
|
||||
{ x int }
|
||||
{ y int }
|
||||
{ z int }
|
||||
{ w int } ;
|
||||
|
||||
STRUCT: uint1
|
||||
{ x uint } ;
|
||||
STRUCT: uint2
|
||||
{ x uint }
|
||||
{ y uint } ;
|
||||
STRUCT: uint3
|
||||
{ x uint }
|
||||
{ y uint }
|
||||
{ z uint } ;
|
||||
STRUCT: uint4
|
||||
{ x uint }
|
||||
{ y uint }
|
||||
{ z uint }
|
||||
{ w uint } ;
|
||||
|
||||
STRUCT: long1
|
||||
{ x long } ;
|
||||
STRUCT: long2
|
||||
{ x long }
|
||||
{ y long } ;
|
||||
STRUCT: long3
|
||||
{ x long }
|
||||
{ y long }
|
||||
{ z long } ;
|
||||
STRUCT: long4
|
||||
{ x long }
|
||||
{ y long }
|
||||
{ z long }
|
||||
{ w long } ;
|
||||
|
||||
STRUCT: ulong1
|
||||
{ x ulong } ;
|
||||
STRUCT: ulong2
|
||||
{ x ulong }
|
||||
{ y ulong } ;
|
||||
STRUCT: ulong3
|
||||
{ x ulong }
|
||||
{ y ulong }
|
||||
{ z ulong } ;
|
||||
STRUCT: ulong4
|
||||
{ x ulong }
|
||||
{ y ulong }
|
||||
{ z ulong }
|
||||
{ w ulong } ;
|
||||
|
||||
STRUCT: longlong1
|
||||
{ x longlong } ;
|
||||
STRUCT: longlong2
|
||||
{ x longlong }
|
||||
{ y longlong } ;
|
||||
STRUCT: longlong3
|
||||
{ x longlong }
|
||||
{ y longlong }
|
||||
{ z longlong } ;
|
||||
STRUCT: longlong4
|
||||
{ x longlong }
|
||||
{ y longlong }
|
||||
{ z longlong }
|
||||
{ w longlong } ;
|
||||
|
||||
STRUCT: ulonglong1
|
||||
{ x ulonglong } ;
|
||||
STRUCT: ulonglong2
|
||||
{ x ulonglong }
|
||||
{ y ulonglong } ;
|
||||
STRUCT: ulonglong3
|
||||
{ x ulonglong }
|
||||
{ y ulonglong }
|
||||
{ z ulonglong } ;
|
||||
STRUCT: ulonglong4
|
||||
{ x ulonglong }
|
||||
{ y ulonglong }
|
||||
{ z ulonglong }
|
||||
{ w ulonglong } ;
|
||||
|
||||
STRUCT: float1
|
||||
{ x float } ;
|
||||
STRUCT: float2
|
||||
{ x float }
|
||||
{ y float } ;
|
||||
STRUCT: float3
|
||||
{ x float }
|
||||
{ y float }
|
||||
{ z float } ;
|
||||
STRUCT: float4
|
||||
{ x float }
|
||||
{ y float }
|
||||
{ z float }
|
||||
{ w float } ;
|
||||
|
||||
STRUCT: double1
|
||||
{ x double } ;
|
||||
STRUCT: double2
|
||||
{ x double }
|
||||
{ y double } ;
|
||||
STRUCT: double3
|
||||
{ x double }
|
||||
{ y double }
|
||||
{ z double } ;
|
||||
STRUCT: double4
|
||||
{ x double }
|
||||
{ y double }
|
||||
{ z double }
|
||||
{ w double } ;
|
||||
|
||||
char2 c-type
|
||||
2 >>align
|
||||
2 >>align-first
|
||||
drop
|
||||
char4 c-type
|
||||
4 >>align
|
||||
4 >>align-first
|
||||
drop
|
||||
|
||||
uchar2 c-type
|
||||
2 >>align
|
||||
2 >>align-first
|
||||
drop
|
||||
uchar4 c-type
|
||||
4 >>align
|
||||
4 >>align-first
|
||||
drop
|
||||
|
||||
short2 c-type
|
||||
4 >>align
|
||||
4 >>align-first
|
||||
drop
|
||||
short4 c-type
|
||||
8 >>align
|
||||
8 >>align-first
|
||||
drop
|
||||
|
||||
ushort2 c-type
|
||||
4 >>align
|
||||
4 >>align-first
|
||||
drop
|
||||
ushort4 c-type
|
||||
8 >>align
|
||||
8 >>align-first
|
||||
drop
|
||||
|
||||
int2 c-type
|
||||
8 >>align
|
||||
8 >>align-first
|
||||
drop
|
||||
int4 c-type
|
||||
16 >>align
|
||||
16 >>align-first
|
||||
drop
|
||||
|
||||
uint2 c-type
|
||||
8 >>align
|
||||
8 >>align-first
|
||||
drop
|
||||
uint4 c-type
|
||||
16 >>align
|
||||
16 >>align-first
|
||||
drop
|
||||
|
||||
long2 c-type
|
||||
long heap-size 2 * >>align
|
||||
long heap-size 2 * >>align-first
|
||||
drop
|
||||
long4 c-type
|
||||
16 >>align
|
||||
16 >>align-first
|
||||
drop
|
||||
|
||||
ulong2 c-type
|
||||
long heap-size 2 * >>align
|
||||
long heap-size 2 * >>align-first
|
||||
drop
|
||||
ulong4 c-type
|
||||
16 >>align
|
||||
16 >>align-first
|
||||
drop
|
||||
|
||||
longlong2 c-type
|
||||
16 >>align
|
||||
16 >>align-first
|
||||
drop
|
||||
longlong4 c-type
|
||||
16 >>align
|
||||
16 >>align-first
|
||||
drop
|
||||
|
||||
ulonglong2 c-type
|
||||
16 >>align
|
||||
16 >>align-first
|
||||
drop
|
||||
ulonglong4 c-type
|
||||
16 >>align
|
||||
16 >>align-first
|
||||
drop
|
||||
|
||||
float2 c-type
|
||||
8 >>align
|
||||
8 >>align-first
|
||||
drop
|
||||
float4 c-type
|
||||
16 >>align
|
||||
16 >>align-first
|
||||
drop
|
||||
|
||||
double2 c-type
|
||||
16 >>align
|
||||
16 >>align-first
|
||||
drop
|
||||
double4 c-type
|
||||
16 >>align
|
||||
16 >>align-first
|
||||
drop
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2010 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types alien.data alien.strings arrays
|
||||
assocs byte-arrays classes.struct combinators cuda.ffi io
|
||||
io.backend io.encodings.utf8 kernel math.parser namespaces
|
||||
assocs byte-arrays classes.struct combinators cuda.ffi
|
||||
io io.backend io.encodings.utf8 kernel math.parser namespaces
|
||||
prettyprint sequences ;
|
||||
IN: cuda.utils
|
||||
|
||||
|
|
@ -21,7 +21,7 @@ ERROR: throw-cuda-error n ;
|
|||
dup CUDA_SUCCESS = [ drop ] [ throw-cuda-error ] if ;
|
||||
|
||||
: init-cuda ( -- )
|
||||
0 cuInit cuda-error ;
|
||||
0 cuInit cuda-error ; inline
|
||||
|
||||
: cuda-version ( -- n )
|
||||
int <c-object> [ cuDriverGetVersion cuda-error ] keep *int ;
|
||||
|
|
@ -40,55 +40,58 @@ ERROR: throw-cuda-error n ;
|
|||
|
||||
: create-context ( flags device -- context )
|
||||
[ CUcontext <c-object> ] 2dip
|
||||
[ cuCtxCreate cuda-error ] 3keep 2drop *void* ;
|
||||
[ cuCtxCreate cuda-error ] 3keep 2drop *void* ; inline
|
||||
|
||||
: destroy-context ( context -- ) cuCtxDestroy cuda-error ;
|
||||
: sync-context ( -- )
|
||||
cuCtxSynchronize cuda-error ; inline
|
||||
|
||||
: launch-function* ( function -- ) cuLaunch cuda-error ;
|
||||
: destroy-context ( context -- ) cuCtxDestroy cuda-error ; inline
|
||||
|
||||
: launch-function ( -- ) cuda-function get cuLaunch cuda-error ;
|
||||
: launch-function* ( function -- ) cuLaunch cuda-error ; inline
|
||||
|
||||
: launch-function ( -- ) cuda-function get cuLaunch cuda-error ; inline
|
||||
|
||||
: cuda-int* ( function offset value -- )
|
||||
cuParamSeti cuda-error ;
|
||||
cuParamSeti cuda-error ; inline
|
||||
|
||||
: cuda-int ( offset value -- )
|
||||
[ cuda-function get ] 2dip cuda-int* ;
|
||||
[ cuda-function get ] 2dip cuda-int* ; inline
|
||||
|
||||
: cuda-float* ( function offset value -- )
|
||||
cuParamSetf cuda-error ;
|
||||
cuParamSetf cuda-error ; inline
|
||||
|
||||
: cuda-float ( offset value -- )
|
||||
[ cuda-function get ] 2dip cuda-float* ;
|
||||
[ cuda-function get ] 2dip cuda-float* ; inline
|
||||
|
||||
: cuda-vector* ( function offset ptr n -- )
|
||||
cuParamSetv cuda-error ;
|
||||
cuParamSetv cuda-error ; inline
|
||||
|
||||
: cuda-vector ( offset ptr n -- )
|
||||
[ cuda-function get ] 3dip cuda-vector* ;
|
||||
[ cuda-function get ] 3dip cuda-vector* ; inline
|
||||
|
||||
: param-size* ( function n -- )
|
||||
cuParamSetSize cuda-error ;
|
||||
cuParamSetSize cuda-error ; inline
|
||||
|
||||
: param-size ( n -- )
|
||||
[ cuda-function get ] dip param-size* ;
|
||||
[ cuda-function get ] dip param-size* ; inline
|
||||
|
||||
: launch-function-grid* ( function width height -- )
|
||||
cuLaunchGrid cuda-error ;
|
||||
cuLaunchGrid cuda-error ; inline
|
||||
|
||||
: launch-function-grid ( width height -- )
|
||||
[ cuda-function get ] 2dip
|
||||
cuLaunchGrid cuda-error ;
|
||||
cuLaunchGrid cuda-error ; inline
|
||||
|
||||
: function-block-shape* ( function x y z -- )
|
||||
cuFuncSetBlockShape cuda-error ;
|
||||
cuFuncSetBlockShape cuda-error ; inline
|
||||
|
||||
: function-block-shape ( x y z -- )
|
||||
[ cuda-function get ] 3dip
|
||||
cuFuncSetBlockShape cuda-error ;
|
||||
cuFuncSetBlockShape cuda-error ; inline
|
||||
|
||||
: function-shared-size* ( function n -- )
|
||||
cuFuncSetSharedSize cuda-error ;
|
||||
cuFuncSetSharedSize cuda-error ; inline
|
||||
|
||||
: function-shared-size ( n -- )
|
||||
[ cuda-function get ] dip
|
||||
cuFuncSetSharedSize cuda-error ;
|
||||
cuFuncSetSharedSize cuda-error ; inline
|
||||
|
|
|
|||
|
|
@ -104,12 +104,12 @@ void *factor_vm::alien_pointer()
|
|||
#define DEFINE_ALIEN_ACCESSOR(name,type,from,to) \
|
||||
VM_C_API void primitive_alien_##name(factor_vm *parent) \
|
||||
{ \
|
||||
parent->ctx->push(from(*(type*)(parent->alien_pointer()),parent)); \
|
||||
parent->ctx->push(parent->from(*(type*)(parent->alien_pointer()))); \
|
||||
} \
|
||||
VM_C_API void primitive_set_alien_##name(factor_vm *parent) \
|
||||
{ \
|
||||
type *ptr = (type *)parent->alien_pointer(); \
|
||||
type value = (type)to(parent->ctx->pop(),parent); \
|
||||
type value = (type)parent->to(parent->ctx->pop()); \
|
||||
*ptr = value; \
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -36,6 +36,9 @@ struct context {
|
|||
set-context-object primitives */
|
||||
cell context_objects[context_object_count];
|
||||
|
||||
/* temporary area used by FFI code generation */
|
||||
s64 long_long_return;
|
||||
|
||||
context(cell datastack_size, cell retainstack_size, cell callstack_size);
|
||||
~context();
|
||||
|
||||
|
|
|
|||
10
vm/math.cpp
10
vm/math.cpp
|
|
@ -491,9 +491,10 @@ s64 factor_vm::to_signed_8(cell obj)
|
|||
}
|
||||
}
|
||||
|
||||
VM_C_API s64 to_signed_8(cell obj, factor_vm *parent)
|
||||
VM_C_API s64 *to_signed_8(cell obj, factor_vm *parent)
|
||||
{
|
||||
return parent->to_signed_8(obj);
|
||||
parent->ctx->long_long_return = parent->to_signed_8(obj);
|
||||
return &parent->ctx->long_long_return;
|
||||
}
|
||||
|
||||
cell factor_vm::from_unsigned_8(u64 n)
|
||||
|
|
@ -524,9 +525,10 @@ u64 factor_vm::to_unsigned_8(cell obj)
|
|||
}
|
||||
}
|
||||
|
||||
VM_C_API u64 to_unsigned_8(cell obj, factor_vm *parent)
|
||||
VM_C_API s64 *to_unsigned_8(cell obj, factor_vm *parent)
|
||||
{
|
||||
return parent->to_unsigned_8(obj);
|
||||
parent->ctx->long_long_return = parent->to_unsigned_8(obj);
|
||||
return &parent->ctx->long_long_return;
|
||||
}
|
||||
|
||||
VM_C_API cell from_float(float flo, factor_vm *parent)
|
||||
|
|
|
|||
|
|
@ -90,8 +90,8 @@ VM_C_API cell from_unsigned_cell(cell integer, factor_vm *vm);
|
|||
VM_C_API cell from_signed_8(s64 n, factor_vm *vm);
|
||||
VM_C_API cell from_unsigned_8(u64 n, factor_vm *vm);
|
||||
|
||||
VM_C_API s64 to_signed_8(cell obj, factor_vm *vm);
|
||||
VM_C_API u64 to_unsigned_8(cell obj, factor_vm *vm);
|
||||
VM_C_API s64 *to_signed_8(cell obj, factor_vm *vm);
|
||||
VM_C_API s64 *to_unsigned_8(cell obj, factor_vm *vm);
|
||||
|
||||
VM_C_API fixnum to_fixnum(cell tagged, factor_vm *vm);
|
||||
VM_C_API cell to_cell(cell tagged, factor_vm *vm);
|
||||
|
|
|
|||
|
|
@ -145,8 +145,8 @@ namespace factor
|
|||
_(unsigned_2,u16,from_unsigned_2,to_cell) \
|
||||
_(signed_1,s8,from_signed_1,to_fixnum) \
|
||||
_(unsigned_1,u8,from_unsigned_1,to_cell) \
|
||||
_(float,float,from_float,to_float) \
|
||||
_(double,double,from_double,to_double) \
|
||||
_(float,float,allot_float,to_float) \
|
||||
_(double,double,allot_float,to_double) \
|
||||
_(cell,void *,allot_alien,pinned_alien_offset)
|
||||
|
||||
#define DECLARE_PRIMITIVE(name) VM_C_API void primitive_##name(factor_vm *parent);
|
||||
|
|
|
|||
Loading…
Reference in New Issue