Merge branch 'master' of git://factorcode.org/git/factor
John Benediktsson
commit
39faa03535
|
|
@ -18,20 +18,16 @@ M: struct-type c-type-align align>> ;
|
|||
M: struct-type c-type-stack-align? drop f ;
|
||||
|
||||
M: struct-type unbox-parameter
|
||||
[ heap-size %unbox-struct ]
|
||||
[ unbox-parameter ]
|
||||
if-value-structs? ;
|
||||
[ %unbox-struct ] [ unbox-parameter ] if-value-structs? ;
|
||||
|
||||
M: struct-type unbox-return
|
||||
f swap heap-size %unbox-struct ;
|
||||
f swap %unbox-struct ;
|
||||
|
||||
M: struct-type box-parameter
|
||||
[ heap-size %box-struct ]
|
||||
[ box-parameter ]
|
||||
if-value-structs? ;
|
||||
[ %box-struct ] [ box-parameter ] if-value-structs? ;
|
||||
|
||||
M: struct-type box-return
|
||||
f swap heap-size %box-struct ;
|
||||
f swap %box-struct ;
|
||||
|
||||
M: struct-type stack-size
|
||||
[ heap-size ] [ stack-size ] if-value-structs? ;
|
||||
|
|
|
|||
|
|
@ -271,9 +271,7 @@ M: #return-recursive generate-node
|
|||
|
||||
! #alien-invoke
|
||||
: large-struct? ( ctype -- ? )
|
||||
dup c-struct? [
|
||||
heap-size struct-small-enough? not
|
||||
] [ drop f ] if ;
|
||||
dup c-struct? [ struct-small-enough? not ] [ drop f ] if ;
|
||||
|
||||
: alien-parameters ( params -- seq )
|
||||
dup parameters>>
|
||||
|
|
@ -304,10 +302,10 @@ M: #return-recursive generate-node
|
|||
alien-parameters parameter-sizes drop ;
|
||||
|
||||
: alien-invoke-frame ( params -- n )
|
||||
#! One cell is temporary storage, temp@
|
||||
dup return>> return-size
|
||||
swap alien-stack-frame +
|
||||
cell + ;
|
||||
#! Two cells for temporary storage, temp@ and on x86.64,
|
||||
#! small struct return value unpacking
|
||||
[ return>> return-size ] [ alien-stack-frame ] bi
|
||||
+ 2 cells + ;
|
||||
|
||||
: set-stack-frame ( n -- )
|
||||
dup [ frame-required ] when* \ stack-frame set ;
|
||||
|
|
@ -361,17 +359,17 @@ M: float-regs inc-reg-class
|
|||
[ spill-param ] [ fastcall-param ] if
|
||||
[ param-reg ] keep ;
|
||||
|
||||
: (flatten-int-type) ( size -- )
|
||||
cell /i "void*" c-type <repetition> % ;
|
||||
: (flatten-int-type) ( size -- types )
|
||||
cell /i "void*" c-type <repetition> ;
|
||||
|
||||
GENERIC: flatten-value-type ( type -- )
|
||||
GENERIC: flatten-value-type ( type -- types )
|
||||
|
||||
M: object flatten-value-type , ;
|
||||
M: object flatten-value-type 1array ;
|
||||
|
||||
M: struct-type flatten-value-type ( type -- )
|
||||
M: struct-type flatten-value-type ( type -- types )
|
||||
stack-size cell align (flatten-int-type) ;
|
||||
|
||||
M: long-long-type flatten-value-type ( type -- )
|
||||
M: long-long-type flatten-value-type ( type -- types )
|
||||
stack-size cell align (flatten-int-type) ;
|
||||
|
||||
: flatten-value-types ( params -- params )
|
||||
|
|
@ -379,9 +377,9 @@ M: long-long-type flatten-value-type ( type -- )
|
|||
[
|
||||
0 [
|
||||
c-type
|
||||
[ parameter-align (flatten-int-type) ] keep
|
||||
[ parameter-align (flatten-int-type) % ] keep
|
||||
[ stack-size cell align + ] keep
|
||||
flatten-value-type
|
||||
flatten-value-type %
|
||||
] reduce drop
|
||||
] { } make ;
|
||||
|
||||
|
|
|
|||
|
|
@ -439,3 +439,109 @@ C-STRUCT: double-rect
|
|||
|
||||
[ 1.0 2.0 3.0 4.0 ]
|
||||
[ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
|
||||
|
||||
C-STRUCT: test_struct_14
|
||||
{ "double" "x1" }
|
||||
{ "double" "x2" } ;
|
||||
|
||||
FUNCTION: test_struct_14 ffi_test_40 ( double x1, double x2 ) ;
|
||||
|
||||
[ 1.0 2.0 ] [
|
||||
1.0 2.0 ffi_test_40
|
||||
[ test_struct_14-x1 ] [ test_struct_14-x2 ] bi
|
||||
] unit-test
|
||||
|
||||
: callback-10 ( -- callback )
|
||||
"test_struct_14" { "double" "double" } "cdecl"
|
||||
[
|
||||
"test_struct_14" <c-object>
|
||||
[ set-test_struct_14-x2 ] keep
|
||||
[ set-test_struct_14-x1 ] keep
|
||||
] alien-callback ;
|
||||
|
||||
: callback-10-test ( x1 x2 callback -- result )
|
||||
"test_struct_14" { "double" "double" } "cdecl" alien-indirect ;
|
||||
|
||||
[ 1.0 2.0 ] [
|
||||
1.0 2.0 callback-10 callback-10-test
|
||||
[ test_struct_14-x1 ] [ test_struct_14-x2 ] bi
|
||||
] unit-test
|
||||
|
||||
FUNCTION: test-struct-12 ffi_test_41 ( int a, double x ) ;
|
||||
|
||||
[ 1 2.0 ] [
|
||||
1 2.0 ffi_test_41
|
||||
[ test-struct-12-a ] [ test-struct-12-x ] bi
|
||||
] unit-test
|
||||
|
||||
: callback-11 ( -- callback )
|
||||
"test-struct-12" { "int" "double" } "cdecl"
|
||||
[
|
||||
"test-struct-12" <c-object>
|
||||
[ set-test-struct-12-x ] keep
|
||||
[ set-test-struct-12-a ] keep
|
||||
] alien-callback ;
|
||||
|
||||
: callback-11-test ( x1 x2 callback -- result )
|
||||
"test-struct-12" { "int" "double" } "cdecl" alien-indirect ;
|
||||
|
||||
[ 1 2.0 ] [
|
||||
1 2.0 callback-11 callback-11-test
|
||||
[ test-struct-12-a ] [ test-struct-12-x ] bi
|
||||
] unit-test
|
||||
|
||||
C-STRUCT: test_struct_15
|
||||
{ "float" "x" }
|
||||
{ "float" "y" } ;
|
||||
|
||||
FUNCTION: test_struct_15 ffi_test_42 ( float x, float y ) ;
|
||||
|
||||
[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ test_struct_15-x ] [ test_struct_15-y ] bi ] unit-test
|
||||
|
||||
: callback-12 ( -- callback )
|
||||
"test_struct_15" { "float" "float" } "cdecl"
|
||||
[
|
||||
"test_struct_15" <c-object>
|
||||
[ set-test_struct_15-y ] keep
|
||||
[ set-test_struct_15-x ] keep
|
||||
] alien-callback ;
|
||||
|
||||
: callback-12-test ( x1 x2 callback -- result )
|
||||
"test_struct_15" { "float" "float" } "cdecl" alien-indirect ;
|
||||
|
||||
[ 1.0 2.0 ] [
|
||||
1.0 2.0 callback-12 callback-12-test
|
||||
[ test_struct_15-x ] [ test_struct_15-y ] bi
|
||||
] unit-test
|
||||
|
||||
C-STRUCT: test_struct_16
|
||||
{ "float" "x" }
|
||||
{ "int" "a" } ;
|
||||
|
||||
FUNCTION: test_struct_16 ffi_test_43 ( float x, int a ) ;
|
||||
|
||||
[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ test_struct_16-x ] [ test_struct_16-a ] bi ] unit-test
|
||||
|
||||
: callback-13 ( -- callback )
|
||||
"test_struct_16" { "float" "int" } "cdecl"
|
||||
[
|
||||
"test_struct_16" <c-object>
|
||||
[ set-test_struct_16-a ] keep
|
||||
[ set-test_struct_16-x ] keep
|
||||
] alien-callback ;
|
||||
|
||||
: callback-13-test ( x1 x2 callback -- result )
|
||||
"test_struct_16" { "float" "int" } "cdecl" alien-indirect ;
|
||||
|
||||
[ 1.0 2 ] [
|
||||
1.0 2 callback-13 callback-13-test
|
||||
[ test_struct_16-x ] [ test_struct_16-a ] bi
|
||||
] unit-test
|
||||
|
||||
FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
|
||||
|
||||
[ 1.0 2.0 ] [ ffi_test_44 [ test_struct_14-x1 ] [ test_struct_14-x2 ] bi ] unit-test
|
||||
|
||||
: stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ;
|
||||
|
||||
[ ] [ stack-frame-bustage 2drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@ HOOK: %box-float cpu ( dst src -- )
|
|||
HOOK: small-enough? cpu ( n -- ? )
|
||||
|
||||
! Is this structure small enough to be returned in registers?
|
||||
HOOK: struct-small-enough? cpu ( size -- ? )
|
||||
HOOK: struct-small-enough? cpu ( heap-size -- ? )
|
||||
|
||||
! Do we pass explode value structs?
|
||||
HOOK: value-structs? cpu ( -- ? )
|
||||
|
|
@ -109,9 +109,9 @@ HOOK: %unbox cpu ( n reg-class func -- )
|
|||
|
||||
HOOK: %unbox-long-long cpu ( n func -- )
|
||||
|
||||
HOOK: %unbox-small-struct cpu ( size -- )
|
||||
HOOK: %unbox-small-struct cpu ( c-type -- )
|
||||
|
||||
HOOK: %unbox-large-struct cpu ( n size -- )
|
||||
HOOK: %unbox-large-struct cpu ( n c-type -- )
|
||||
|
||||
HOOK: %box cpu ( n reg-class func -- )
|
||||
|
||||
|
|
@ -119,9 +119,9 @@ HOOK: %box-long-long cpu ( n func -- )
|
|||
|
||||
HOOK: %prepare-box-struct cpu ( size -- )
|
||||
|
||||
HOOK: %box-small-struct cpu ( size -- )
|
||||
HOOK: %box-small-struct cpu ( c-type -- )
|
||||
|
||||
HOOK: %box-large-struct cpu ( n size -- )
|
||||
HOOK: %box-large-struct cpu ( n c-type -- )
|
||||
|
||||
GENERIC: %save-param-reg ( stack reg reg-class -- )
|
||||
|
||||
|
|
@ -169,14 +169,14 @@ PREDICATE: small-tagged < integer v>operand small-enough? ;
|
|||
[ [ nip ] prepose ] dip if ;
|
||||
inline
|
||||
|
||||
: %unbox-struct ( n size -- )
|
||||
: %unbox-struct ( n c-type -- )
|
||||
[
|
||||
%unbox-small-struct
|
||||
] [
|
||||
%unbox-large-struct
|
||||
] if-small-struct ;
|
||||
|
||||
: %box-struct ( n size -- )
|
||||
: %box-struct ( n c-type -- )
|
||||
[
|
||||
%box-small-struct
|
||||
] [
|
||||
|
|
|
|||
|
|
@ -195,12 +195,12 @@ M: ppc %unbox-long-long ( n func -- )
|
|||
4 1 rot cell + local@ STW
|
||||
] when* ;
|
||||
|
||||
M: ppc %unbox-large-struct ( n size -- )
|
||||
M: ppc %unbox-large-struct ( n c-type -- )
|
||||
! Value must be in r3
|
||||
! Compute destination address
|
||||
4 1 roll local@ ADDI
|
||||
! Load struct size
|
||||
5 LI
|
||||
heap-size 5 LI
|
||||
! Call the function
|
||||
"to_value_struct" f %alien-invoke ;
|
||||
|
||||
|
|
@ -227,8 +227,9 @@ M: ppc %prepare-box-struct ( size -- )
|
|||
3 1 rot f struct-return@ ADDI
|
||||
3 1 0 local@ STW ;
|
||||
|
||||
M: ppc %box-large-struct ( n size -- )
|
||||
M: ppc %box-large-struct ( n c-type -- )
|
||||
#! If n = f, then we're boxing a returned struct
|
||||
heap-size
|
||||
[ swap struct-return@ ] keep
|
||||
! Compute destination address
|
||||
3 1 roll ADDI
|
||||
|
|
|
|||
|
|
@ -28,6 +28,10 @@ M: x86.32 %alien-global 0 [] MOV rc-absolute-cell rel-dlsym ;
|
|||
|
||||
M: x86.32 %alien-invoke (CALL) rel-dlsym ;
|
||||
|
||||
M: x86.32 struct-small-enough? ( size -- ? )
|
||||
heap-size { 1 2 4 8 } member?
|
||||
os { linux netbsd solaris } member? not and ;
|
||||
|
||||
! On x86, parameters are never passed in registers.
|
||||
M: int-regs return-reg drop EAX ;
|
||||
M: int-regs param-regs drop { } ;
|
||||
|
|
@ -73,62 +77,6 @@ M: object %load-param-reg 3drop ;
|
|||
|
||||
M: object %save-param-reg 3drop ;
|
||||
|
||||
M: x86.32 %prepare-unbox ( -- )
|
||||
#! Move top of data stack to EAX.
|
||||
EAX ESI [] MOV
|
||||
ESI 4 SUB ;
|
||||
|
||||
: (%unbox) ( func -- )
|
||||
4 [
|
||||
! Push parameter
|
||||
EAX PUSH
|
||||
! Call the unboxer
|
||||
f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86.32 %unbox ( n reg-class func -- )
|
||||
#! The value being unboxed must already be in EAX.
|
||||
#! If n is f, we're unboxing a return value about to be
|
||||
#! returned by the callback. Otherwise, we're unboxing
|
||||
#! a parameter to a C function about to be called.
|
||||
(%unbox)
|
||||
! Store the return value on the C stack
|
||||
over [ store-return-reg ] [ 2drop ] if ;
|
||||
|
||||
M: x86.32 %unbox-long-long ( n func -- )
|
||||
(%unbox)
|
||||
! Store the return value on the C stack
|
||||
[
|
||||
dup stack@ EAX MOV
|
||||
cell + stack@ EDX MOV
|
||||
] when* ;
|
||||
|
||||
M: x86.32 %unbox-struct-2
|
||||
#! Alien must be in EAX.
|
||||
4 [
|
||||
EAX PUSH
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load second cell
|
||||
EDX EAX 4 [+] MOV
|
||||
! Load first cell
|
||||
EAX EAX [] MOV
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86.32 %unbox-large-struct ( n size -- )
|
||||
#! Alien must be in EAX.
|
||||
! Compute destination address
|
||||
ECX ESP roll [+] LEA
|
||||
12 [
|
||||
! Push struct size
|
||||
PUSH
|
||||
! Push destination address
|
||||
ECX PUSH
|
||||
! Push source address
|
||||
EAX PUSH
|
||||
! Copy the struct to the stack
|
||||
"to_value_struct" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
: box@ ( n reg-class -- stack@ )
|
||||
#! Used for callbacks; we want to box the values given to
|
||||
#! us by the C function caller. Computes stack location of
|
||||
|
|
@ -172,8 +120,9 @@ M: x86.32 %box-long-long ( n func -- )
|
|||
: struct-return@ ( size n -- n )
|
||||
[ stack-frame* cell + + ] [ \ stack-frame get swap - ] ?if ;
|
||||
|
||||
M: x86.32 %box-large-struct ( n size -- )
|
||||
M: x86.32 %box-large-struct ( n c-type -- )
|
||||
! Compute destination address
|
||||
heap-size
|
||||
[ swap struct-return@ ] keep
|
||||
ECX ESP roll [+] LEA
|
||||
8 [
|
||||
|
|
@ -191,7 +140,46 @@ M: x86.32 %prepare-box-struct ( size -- )
|
|||
! Store it as the first parameter
|
||||
ESP [] EAX MOV ;
|
||||
|
||||
M: x86.32 %unbox-struct-1
|
||||
M: x86.32 %box-small-struct ( c-type -- )
|
||||
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
|
||||
12 [
|
||||
heap-size PUSH
|
||||
EDX PUSH
|
||||
EAX PUSH
|
||||
"box_small_struct" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86.32 %prepare-unbox ( -- )
|
||||
#! Move top of data stack to EAX.
|
||||
EAX ESI [] MOV
|
||||
ESI 4 SUB ;
|
||||
|
||||
: (%unbox) ( func -- )
|
||||
4 [
|
||||
! Push parameter
|
||||
EAX PUSH
|
||||
! Call the unboxer
|
||||
f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86.32 %unbox ( n reg-class func -- )
|
||||
#! The value being unboxed must already be in EAX.
|
||||
#! If n is f, we're unboxing a return value about to be
|
||||
#! returned by the callback. Otherwise, we're unboxing
|
||||
#! a parameter to a C function about to be called.
|
||||
(%unbox)
|
||||
! Store the return value on the C stack
|
||||
over [ store-return-reg ] [ 2drop ] if ;
|
||||
|
||||
M: x86.32 %unbox-long-long ( n func -- )
|
||||
(%unbox)
|
||||
! Store the return value on the C stack
|
||||
[
|
||||
dup stack@ EAX MOV
|
||||
cell + stack@ EDX MOV
|
||||
] when* ;
|
||||
|
||||
: %unbox-struct-1 ( -- )
|
||||
#! Alien must be in EAX.
|
||||
4 [
|
||||
EAX PUSH
|
||||
|
|
@ -200,13 +188,38 @@ M: x86.32 %unbox-struct-1
|
|||
EAX EAX [] MOV
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86.32 %box-small-struct ( size -- )
|
||||
#! Box a <= 8-byte struct returned in EAX:DX. OS X only.
|
||||
12 [
|
||||
PUSH
|
||||
EDX PUSH
|
||||
: %unbox-struct-2 ( -- )
|
||||
#! Alien must be in EAX.
|
||||
4 [
|
||||
EAX PUSH
|
||||
"box_small_struct" f %alien-invoke
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load second cell
|
||||
EDX EAX 4 [+] MOV
|
||||
! Load first cell
|
||||
EAX EAX [] MOV
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86 %unbox-small-struct ( size -- )
|
||||
#! Alien must be in EAX.
|
||||
heap-size cell align cell /i {
|
||||
{ 1 [ %unbox-struct-1 ] }
|
||||
{ 2 [ %unbox-struct-2 ] }
|
||||
} case ;
|
||||
|
||||
M: x86.32 %unbox-large-struct ( n c-type -- )
|
||||
#! Alien must be in EAX.
|
||||
heap-size
|
||||
! Compute destination address
|
||||
ECX ESP roll [+] LEA
|
||||
12 [
|
||||
! Push struct size
|
||||
PUSH
|
||||
! Push destination address
|
||||
ECX PUSH
|
||||
! Push source address
|
||||
EAX PUSH
|
||||
! Copy the struct to the stack
|
||||
"to_value_struct" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
M: x86.32 %prepare-alien-indirect ( -- )
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2005, 2007 Slava Pestov.
|
||||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types arrays cpu.x86.assembler
|
||||
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
|
||||
|
|
@ -6,7 +6,7 @@ cpu.x86.allot cpu.architecture kernel kernel.private math
|
|||
namespaces make sequences compiler.generator
|
||||
compiler.generator.registers compiler.generator.fixup system
|
||||
layouts alien alien.accessors alien.structs slots splitting
|
||||
assocs ;
|
||||
assocs combinators ;
|
||||
IN: cpu.x86.64
|
||||
|
||||
M: x86.64 ds-reg R14 ;
|
||||
|
|
@ -48,6 +48,44 @@ M: stack-params %load-param-reg
|
|||
M: stack-params %save-param-reg
|
||||
>r stack-frame* + cell + swap r> %load-param-reg ;
|
||||
|
||||
: with-return-regs ( quot -- )
|
||||
[
|
||||
V{ RDX RAX } clone int-regs set
|
||||
V{ XMM1 XMM0 } clone float-regs set
|
||||
call
|
||||
] with-scope ; inline
|
||||
|
||||
! The ABI for passing structs by value is pretty messed up
|
||||
<< "void*" c-type clone "__stack_value" define-primitive-type
|
||||
stack-params "__stack_value" c-type (>>reg-class) >>
|
||||
|
||||
: struct-types&offset ( struct-type -- pairs )
|
||||
fields>> [
|
||||
[ type>> ] [ offset>> ] bi 2array
|
||||
] map ;
|
||||
|
||||
: split-struct ( pairs -- seq )
|
||||
[
|
||||
[ 8 mod zero? [ t , ] when , ] assoc-each
|
||||
] { } make { t } split harvest ;
|
||||
|
||||
: flatten-small-struct ( c-type -- seq )
|
||||
struct-types&offset split-struct [
|
||||
[ c-type c-type-reg-class ] map
|
||||
int-regs swap member? "void*" "double" ? c-type
|
||||
] map ;
|
||||
|
||||
: flatten-large-struct ( c-type -- seq )
|
||||
heap-size cell align
|
||||
cell /i "__stack_value" c-type <repetition> ;
|
||||
|
||||
M: struct-type flatten-value-type ( type -- seq )
|
||||
dup heap-size 16 > [
|
||||
flatten-large-struct
|
||||
] [
|
||||
flatten-small-struct
|
||||
] if ;
|
||||
|
||||
M: x86.64 %prepare-unbox ( -- )
|
||||
! First parameter is top of stack
|
||||
RDI R14 [] MOV
|
||||
|
|
@ -62,22 +100,26 @@ M: x86.64 %unbox ( n reg-class func -- )
|
|||
M: x86.64 %unbox-long-long ( n func -- )
|
||||
int-regs swap %unbox ;
|
||||
|
||||
M: x86.64 %unbox-struct-1 ( -- )
|
||||
#! Alien must be in RDI.
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load first cell
|
||||
RAX RAX [] MOV ;
|
||||
: %unbox-struct-field ( c-type i -- )
|
||||
! Alien must be in RDI.
|
||||
RDI swap cells [+] swap reg-class>> {
|
||||
{ int-regs [ int-regs get pop swap MOV ] }
|
||||
{ double-float-regs [ float-regs get pop swap MOVSD ] }
|
||||
} case ;
|
||||
|
||||
M: x86.64 %unbox-struct-2 ( -- )
|
||||
#! Alien must be in RDI.
|
||||
M: x86.64 %unbox-small-struct ( c-type -- )
|
||||
! Alien must be in RDI.
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load second cell
|
||||
RDX RAX cell [+] MOV
|
||||
! Load first cell
|
||||
RAX RAX [] MOV ;
|
||||
! Move alien_offset() return value to RDI so that we don't
|
||||
! clobber it.
|
||||
RDI RAX MOV
|
||||
[
|
||||
flatten-small-struct [ %unbox-struct-field ] each-index
|
||||
] with-return-regs ;
|
||||
|
||||
M: x86.64 %unbox-large-struct ( n size -- )
|
||||
M: x86.64 %unbox-large-struct ( n c-type -- )
|
||||
! Source is in RDI
|
||||
heap-size
|
||||
! Load destination address
|
||||
RSI RSP roll [+] LEA
|
||||
! Load structure size
|
||||
|
|
@ -100,20 +142,33 @@ M: x86.64 %box ( n reg-class func -- )
|
|||
M: x86.64 %box-long-long ( n func -- )
|
||||
int-regs swap %box ;
|
||||
|
||||
M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ;
|
||||
M: x86.64 struct-small-enough? ( size -- ? )
|
||||
heap-size 2 cells <= ;
|
||||
|
||||
M: x86.64 %box-small-struct ( size -- )
|
||||
#! Box a <= 16-byte struct returned in RAX:RDX.
|
||||
RDI RAX MOV
|
||||
RSI RDX MOV
|
||||
RDX swap MOV
|
||||
"box_small_struct" f %alien-invoke ;
|
||||
: box-struct-field@ ( i -- operand ) RSP swap 1+ cells [+] ;
|
||||
|
||||
: %box-struct-field ( c-type i -- )
|
||||
box-struct-field@ swap reg-class>> {
|
||||
{ int-regs [ int-regs get pop MOV ] }
|
||||
{ double-float-regs [ float-regs get pop MOVSD ] }
|
||||
} case ;
|
||||
|
||||
M: x86.64 %box-small-struct ( c-type -- )
|
||||
#! Box a <= 16-byte struct.
|
||||
[
|
||||
[ flatten-small-struct [ %box-struct-field ] each-index ]
|
||||
[ RDX swap heap-size MOV ] bi
|
||||
RDI 0 box-struct-field@ MOV
|
||||
RSI 1 box-struct-field@ MOV
|
||||
"box_small_struct" f %alien-invoke
|
||||
] with-return-regs ;
|
||||
|
||||
: struct-return@ ( size n -- n )
|
||||
[ ] [ \ stack-frame get swap - ] ?if ;
|
||||
|
||||
M: x86.64 %box-large-struct ( n size -- )
|
||||
M: x86.64 %box-large-struct ( n c-type -- )
|
||||
! Struct size is parameter 2
|
||||
heap-size
|
||||
RSI over MOV
|
||||
! Compute destination address
|
||||
swap struct-return@ RDI RSP rot [+] LEA
|
||||
|
|
@ -170,32 +225,3 @@ USE: cpu.x86.intrinsics
|
|||
|
||||
\ alien-signed-4 small-reg-32 define-signed-getter
|
||||
\ set-alien-signed-4 small-reg-32 define-setter
|
||||
|
||||
! The ABI for passing structs by value is pretty messed up
|
||||
<< "void*" c-type clone "__stack_value" define-primitive-type
|
||||
stack-params "__stack_value" c-type (>>reg-class) >>
|
||||
|
||||
: struct-types&offset ( struct-type -- pairs )
|
||||
fields>> [
|
||||
[ type>> ] [ offset>> ] bi 2array
|
||||
] map ;
|
||||
|
||||
: split-struct ( pairs -- seq )
|
||||
[
|
||||
[ 8 mod zero? [ t , ] when , ] assoc-each
|
||||
] { } make { t } split harvest ;
|
||||
|
||||
: flatten-large-struct ( type -- )
|
||||
heap-size cell align
|
||||
cell /i "__stack_value" c-type <repetition> % ;
|
||||
|
||||
M: struct-type flatten-value-type ( type -- seq )
|
||||
dup heap-size 16 > [
|
||||
flatten-large-struct
|
||||
] [
|
||||
struct-types&offset split-struct [
|
||||
[ c-type c-type-reg-class ] map
|
||||
int-regs swap member?
|
||||
"void*" "double" ? c-type ,
|
||||
] each
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -139,21 +139,6 @@ M: x86 small-enough? ( n -- ? )
|
|||
|
||||
: temp@ ( n -- op ) stack-reg \ stack-frame get rot - [+] ;
|
||||
|
||||
HOOK: %unbox-struct-1 cpu ( -- )
|
||||
|
||||
HOOK: %unbox-struct-2 cpu ( -- )
|
||||
|
||||
M: x86 %unbox-small-struct ( size -- )
|
||||
#! Alien must be in EAX.
|
||||
cell align cell /i {
|
||||
{ 1 [ %unbox-struct-1 ] }
|
||||
{ 2 [ %unbox-struct-2 ] }
|
||||
} case ;
|
||||
|
||||
M: x86 struct-small-enough? ( size -- ? )
|
||||
{ 1 2 4 8 } member?
|
||||
os { linux netbsd solaris } member? not and ;
|
||||
|
||||
M: x86 %return ( -- ) 0 %unwind ;
|
||||
|
||||
! Alien intrinsics
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ calendar.format accessors sets hashtables ;
|
|||
IN: smtp
|
||||
|
||||
SYMBOL: smtp-domain
|
||||
SYMBOL: smtp-server "localhost" "smtp" <inet> smtp-server set-global
|
||||
SYMBOL: smtp-server "localhost" 25 <inet> smtp-server set-global
|
||||
SYMBOL: smtp-read-timeout 1 minutes smtp-read-timeout set-global
|
||||
SYMBOL: esmtp? t esmtp? set-global
|
||||
|
||||
|
|
|
|||
|
|
@ -102,7 +102,7 @@ set_make() {
|
|||
*) MAKE='make';;
|
||||
esac
|
||||
if ! [[ $MAKE -eq 'gmake' ]] ; then
|
||||
ensure_program_installed gmake
|
||||
ensure_program_installed gmake
|
||||
fi
|
||||
}
|
||||
|
||||
|
|
@ -159,6 +159,7 @@ check_factor_exists() {
|
|||
}
|
||||
|
||||
find_os() {
|
||||
if [[ -n $OS ]] ; then return; fi
|
||||
$ECHO "Finding OS..."
|
||||
uname_s=`uname -s`
|
||||
check_ret uname
|
||||
|
|
@ -178,6 +179,7 @@ find_os() {
|
|||
}
|
||||
|
||||
find_architecture() {
|
||||
if [[ -n $ARCH ]] ; then return; fi
|
||||
$ECHO "Finding ARCH..."
|
||||
uname_m=`uname -m`
|
||||
check_ret uname
|
||||
|
|
@ -197,7 +199,7 @@ write_test_program() {
|
|||
echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c
|
||||
}
|
||||
|
||||
find_word_size() {
|
||||
c_find_word_size() {
|
||||
$ECHO "Finding WORD..."
|
||||
C_WORD=factor-word-size
|
||||
write_test_program
|
||||
|
|
@ -207,6 +209,29 @@ find_word_size() {
|
|||
rm -f $C_WORD*
|
||||
}
|
||||
|
||||
intel_macosx_word_size() {
|
||||
ensure_program_installed sysctl
|
||||
$ECHO -n "Testing if your Intel Mac supports 64bit binaries..."
|
||||
sysctl machdep.cpu.extfeatures | grep EM64T >/dev/null
|
||||
if [[ $? -eq 0 ]] ; then
|
||||
WORD=32
|
||||
$ECHO "yes!"
|
||||
$ECHO "Defaulting to 32bit for now though..."
|
||||
else
|
||||
WORD=32
|
||||
$ECHO "no."
|
||||
fi
|
||||
}
|
||||
|
||||
find_word_size() {
|
||||
if [[ -n $WORD ]] ; then return; fi
|
||||
if [[ $OS == macosx && $ARCH == x86 ]] ; then
|
||||
intel_macosx_word_size
|
||||
else
|
||||
c_find_word_size
|
||||
fi
|
||||
}
|
||||
|
||||
set_factor_binary() {
|
||||
case $OS in
|
||||
# winnt) FACTOR_BINARY=factor-nt;;
|
||||
|
|
@ -230,15 +255,18 @@ echo_build_info() {
|
|||
$ECHO MAKE=$MAKE
|
||||
}
|
||||
|
||||
set_build_info() {
|
||||
check_os_arch_word() {
|
||||
if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then
|
||||
$ECHO "OS: $OS"
|
||||
$ECHO "ARCH: $ARCH"
|
||||
$ECHO "WORD: $WORD"
|
||||
$ECHO "OS, ARCH, or WORD is empty. Please report this"
|
||||
$ECHO "OS, ARCH, or WORD is empty. Please report this."
|
||||
exit 5
|
||||
fi
|
||||
}
|
||||
|
||||
set_build_info() {
|
||||
check_os_arch_word
|
||||
MAKE_TARGET=$OS-$ARCH-$WORD
|
||||
MAKE_IMAGE_TARGET=$ARCH.$WORD
|
||||
BOOT_IMAGE=boot.$ARCH.$WORD.image
|
||||
|
|
@ -254,15 +282,32 @@ set_build_info() {
|
|||
fi
|
||||
}
|
||||
|
||||
parse_build_info() {
|
||||
ensure_program_installed cut
|
||||
$ECHO "Parsing make target from command line: $1"
|
||||
OS=`echo $1 | cut -d '-' -f 1`
|
||||
ARCH=`echo $1 | cut -d '-' -f 2`
|
||||
WORD=`echo $1 | cut -d '-' -f 3`
|
||||
|
||||
if [[ $OS == linux && $ARCH == ppc ]] ; then WORD=32; fi
|
||||
if [[ $OS == linux && $ARCH == arm ]] ; then WORD=32; fi
|
||||
if [[ $OS == macosx && $ARCH == ppc ]] ; then WORD=32; fi
|
||||
if [[ $OS == wince && $ARCH == arm ]] ; then WORD=32; fi
|
||||
|
||||
$ECHO "OS=$OS"
|
||||
$ECHO "ARCH=$ARCH"
|
||||
$ECHO "WORD=$WORD"
|
||||
}
|
||||
|
||||
find_build_info() {
|
||||
find_os
|
||||
find_architecture
|
||||
find_word_size
|
||||
set_factor_binary
|
||||
set_build_info
|
||||
set_downloader
|
||||
set_gcc
|
||||
set_make
|
||||
set_downloader
|
||||
set_gcc
|
||||
set_make
|
||||
echo_build_info
|
||||
}
|
||||
|
||||
|
|
@ -415,30 +460,37 @@ make_boot_image() {
|
|||
}
|
||||
|
||||
install_build_system_apt() {
|
||||
ensure_program_installed yes
|
||||
yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
|
||||
sudo apt-get --yes install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
|
||||
check_ret sudo
|
||||
}
|
||||
|
||||
install_build_system_port() {
|
||||
test_program_installed git
|
||||
if [[ $? -ne 1 ]] ; then
|
||||
ensure_program_installed yes
|
||||
echo "git not found."
|
||||
echo "This script requires either git-core or port."
|
||||
echo "If it fails, install git-core or port and try again."
|
||||
ensure_program_installed port
|
||||
echo "Installing git-core with port...this will take awhile."
|
||||
yes | sudo port install git-core
|
||||
ensure_program_installed yes
|
||||
echo "git not found."
|
||||
echo "This script requires either git-core or port."
|
||||
echo "If it fails, install git-core or port and try again."
|
||||
ensure_program_installed port
|
||||
echo "Installing git-core with port...this will take awhile."
|
||||
yes | sudo port install git-core
|
||||
fi
|
||||
}
|
||||
|
||||
usage() {
|
||||
echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|dlls|net-bootstrap|make-target"
|
||||
echo "usage: $0 install|install-x11|install-macosx|self-update|quick-update|update|bootstrap|dlls|net-bootstrap|make-target|report [optional-target]"
|
||||
echo "If you are behind a firewall, invoke as:"
|
||||
echo "env GIT_PROTOCOL=http $0 <command>"
|
||||
echo ""
|
||||
echo "Example for overriding the default target:"
|
||||
echo " $0 update macosx-x86-32"
|
||||
}
|
||||
|
||||
# -n is nonzero length, -z is zero length
|
||||
if [[ -n "$2" ]] ; then
|
||||
parse_build_info $2
|
||||
fi
|
||||
|
||||
case "$1" in
|
||||
install) install ;;
|
||||
install-x11) install_build_system_apt; install ;;
|
||||
|
|
@ -447,8 +499,9 @@ case "$1" in
|
|||
quick-update) update; refresh_image ;;
|
||||
update) update; update_bootstrap ;;
|
||||
bootstrap) get_config_info; bootstrap ;;
|
||||
report) find_build_info ;;
|
||||
dlls) get_config_info; maybe_download_dlls;;
|
||||
net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
|
||||
make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;;
|
||||
make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;;
|
||||
*) usage ;;
|
||||
esac
|
||||
|
|
|
|||
|
|
@ -334,7 +334,7 @@ HELP: if-empty
|
|||
{ $values { "seq" sequence } { "quot1" quotation } { "quot2" quotation } }
|
||||
{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and " { $snippet "quot1" } " is called. Otherwise, if the sequence has any elements, " { $snippet "quot2" } " is called on it." }
|
||||
{ $example
|
||||
"USING: kernel prettyprint sequences sequences.lib ;"
|
||||
"USING: kernel prettyprint sequences ;"
|
||||
"{ 1 2 3 } [ \"empty sequence\" ] [ sum ] if-empty ."
|
||||
"6"
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -54,19 +54,19 @@ SYMBOL: load-help?
|
|||
: load-source ( vocab -- vocab )
|
||||
f over set-vocab-source-loaded?
|
||||
[ vocab-source-path [ parse-file ] [ [ ] ] if* ] keep
|
||||
t over set-vocab-source-loaded?
|
||||
[ [ % ] [ call ] if-bootstrapping ] dip ;
|
||||
t swap set-vocab-source-loaded?
|
||||
[ % ] [ call ] if-bootstrapping ;
|
||||
|
||||
: load-docs ( vocab -- vocab )
|
||||
load-help? get [
|
||||
f over set-vocab-docs-loaded?
|
||||
[ vocab-docs-path [ ?run-file ] when* ] keep
|
||||
t over set-vocab-docs-loaded?
|
||||
] when ;
|
||||
t swap set-vocab-docs-loaded?
|
||||
] [ drop ] if ;
|
||||
|
||||
: reload ( name -- )
|
||||
[
|
||||
dup vocab [ load-source load-docs drop ] [ no-vocab ] ?if
|
||||
dup vocab [ [ load-source ] [ load-docs ] bi ] [ no-vocab ] ?if
|
||||
] with-compiler-errors ;
|
||||
|
||||
: require ( vocab -- )
|
||||
|
|
@ -90,8 +90,8 @@ GENERIC: (load-vocab) ( name -- )
|
|||
|
||||
M: vocab (load-vocab)
|
||||
[
|
||||
dup vocab-source-loaded? [ load-source ] unless
|
||||
dup vocab-docs-loaded? [ load-docs ] unless
|
||||
dup vocab-source-loaded? [ dup load-source ] unless
|
||||
dup vocab-docs-loaded? [ dup load-docs ] unless
|
||||
drop
|
||||
] [ [ swap add-to-blacklist ] keep rethrow ] recover ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
example
|
||||
examples
|
||||
|
|
|
|||
|
|
@ -31,3 +31,7 @@ IN: regexp2.parser
|
|||
[ ] [ "[a-c]" test-regexp ] unit-test
|
||||
[ ] [ "[^a-c]" test-regexp ] unit-test
|
||||
[ "[^]" test-regexp ] must-fail
|
||||
|
||||
[ ] [ "|b" test-regexp ] unit-test
|
||||
[ ] [ "b|" test-regexp ] unit-test
|
||||
[ ] [ "||" test-regexp ] unit-test
|
||||
|
|
|
|||
|
|
@ -67,7 +67,7 @@ left-parenthesis pipe caret dash ;
|
|||
: <negation> ( obj -- negation ) negation boa ;
|
||||
: <concatenation> ( seq -- concatenation )
|
||||
>vector get-reversed-regexp [ reverse ] when
|
||||
concatenation boa ;
|
||||
[ epsilon ] [ concatenation boa ] if-empty ;
|
||||
: <alternation> ( seq -- alternation ) >vector alternation boa ;
|
||||
: <capture-group> ( obj -- capture-group ) capture-group boa ;
|
||||
: <kleene-star> ( obj -- kleene-star ) kleene-star boa ;
|
||||
|
|
|
|||
|
|
@ -14,6 +14,13 @@ IN: regexp2-tests
|
|||
[ t ] [ "c" "a|b|c" <regexp> matches? ] unit-test
|
||||
[ f ] [ "c" "d|e|f" <regexp> matches? ] unit-test
|
||||
|
||||
[ t ] [ "b" "|b" <regexp> matches? ] unit-test
|
||||
[ t ] [ "b" "b|" <regexp> matches? ] unit-test
|
||||
[ t ] [ "" "b|" <regexp> matches? ] unit-test
|
||||
[ t ] [ "" "b|" <regexp> matches? ] unit-test
|
||||
[ f ] [ "" "|" <regexp> matches? ] unit-test
|
||||
[ f ] [ "" "|||||||" <regexp> matches? ] unit-test
|
||||
|
||||
[ f ] [ "aa" "a|b|c" <regexp> matches? ] unit-test
|
||||
[ f ] [ "bb" "a|b|c" <regexp> matches? ] unit-test
|
||||
[ f ] [ "cc" "a|b|c" <regexp> matches? ] unit-test
|
||||
|
|
|
|||
|
|
@ -280,3 +280,48 @@ int ffi_test_39(long a, long b, struct test_struct_13 s)
|
|||
if(a != b) abort();
|
||||
return s.x1 + s.x2 + s.x3 + s.x4 + s.x5 + s.x6;
|
||||
}
|
||||
|
||||
struct test_struct_14 ffi_test_40(double x1, double x2)
|
||||
{
|
||||
struct test_struct_14 retval;
|
||||
retval.x1 = x1;
|
||||
retval.x2 = x2;
|
||||
printf("ffi_test_40(%f,%f)\n",x1,x2);
|
||||
return retval;
|
||||
}
|
||||
|
||||
struct test_struct_12 ffi_test_41(int a, double x)
|
||||
{
|
||||
struct test_struct_12 retval;
|
||||
retval.a = a;
|
||||
retval.x = x;
|
||||
printf("ffi_test_41(%d,%f)\n",a,x);
|
||||
return retval;
|
||||
}
|
||||
|
||||
struct test_struct_15 ffi_test_42(float x, float y)
|
||||
{
|
||||
struct test_struct_15 retval;
|
||||
retval.x = x;
|
||||
retval.y = y;
|
||||
printf("ffi_test_42(%f,%f)\n",x,y);
|
||||
return retval;
|
||||
}
|
||||
|
||||
struct test_struct_16 ffi_test_43(float x, int a)
|
||||
{
|
||||
struct test_struct_16 retval;
|
||||
retval.x = x;
|
||||
retval.a = a;
|
||||
printf("ffi_test_43(%f,%d)\n",x,a);
|
||||
return retval;
|
||||
}
|
||||
|
||||
struct test_struct_14 ffi_test_44(void)
|
||||
{
|
||||
struct test_struct_14 retval;
|
||||
retval.x1 = 1.0;
|
||||
retval.x2 = 2.0;
|
||||
//printf("ffi_test_44()\n");
|
||||
return retval;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -71,3 +71,19 @@ DLLEXPORT unsigned long long ffi_test_38(unsigned long long x, unsigned long lon
|
|||
struct test_struct_13 { float x1, x2, x3, x4, x5, x6; };
|
||||
|
||||
DLLEXPORT int ffi_test_39(long a, long b, struct test_struct_13 s);
|
||||
|
||||
struct test_struct_14 { double x1, x2; };
|
||||
|
||||
DLLEXPORT struct test_struct_14 ffi_test_40(double x1, double x2);
|
||||
|
||||
DLLEXPORT struct test_struct_12 ffi_test_41(int a, double x);
|
||||
|
||||
struct test_struct_15 { float x, y; };
|
||||
|
||||
DLLEXPORT struct test_struct_15 ffi_test_42(float x, float y);
|
||||
|
||||
struct test_struct_16 { float x; int a; };
|
||||
|
||||
DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a);
|
||||
|
||||
DLLEXPORT struct test_struct_14 ffi_test_44();
|
||||
|
|
|
|||
Loading…
Reference in New Issue