CODEGEN: ##compare-float-ordered %compare-float-ordered
CODEGEN: ##compare-float-unordered %compare-float-unordered
CODEGEN: ##save-context %save-context
- CODEGEN: ##vm-field-ptr %vm-field-ptr
CODEGEN: ##vm-field %vm-field
+ CODEGEN: ##set-vm-field %set-vm-field
CODEGEN: _fixnum-add %fixnum-add
CODEGEN: _fixnum-sub %fixnum-sub
M: double-rep next-fastcall-param
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
-GENERIC: reg-class-full? ( reg-class -- ? )
+GENERIC# reg-class-full? 1 ( reg-class abi -- ? )
-M: stack-params reg-class-full? drop t ;
+M: stack-params reg-class-full? 2drop t ;
M: reg-class reg-class-full?
- [ get ] [ param-regs length ] bi >= ;
+ [ get ] swap '[ _ param-regs length ] bi >= ;
: alloc-stack-param ( rep -- n reg-class rep )
stack-params get
: alloc-fastcall-param ( rep -- n reg-class rep )
[ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;
-: alloc-parameter ( parameter -- reg rep )
- c-type-rep dup reg-class-of reg-class-full?
+:: alloc-parameter ( parameter abi -- reg rep )
+ parameter c-type-rep dup reg-class-of abi reg-class-full?
[ alloc-stack-param ] [ alloc-fastcall-param ] if
- [ param-reg ] dip ;
+ [ abi param-reg ] dip ;
+
+SYMBOL: (stack-value)
+<< void* c-type clone \ (stack-value) define-primitive-type
+stack-params \ (stack-value) c-type (>>rep) >>
+
+: ((flatten-type)) ( type to-type -- seq )
+ [ stack-size cell align cell /i ] dip c-type <repetition> ; inline
: (flatten-int-type) ( type -- seq )
- stack-size cell align cell /i void* c-type <repetition> ;
+ void* ((flatten-type)) ;
+: (flatten-stack-type) ( type -- seq )
+ (stack-value) ((flatten-type)) ;
GENERIC: flatten-value-type ( type -- types )
#! Moves values from C stack to registers (if word is
#! %load-param-reg) and registers to C stack (if word is
#! %save-param-reg).
- [ alien-parameters flatten-value-types ]
- [ '[ alloc-parameter _ execute ] ]
+ [ [ alien-parameters flatten-value-types ] [ abi>> ] bi ]
+ [ '[ _ alloc-parameter _ execute ] ]
bi* each-parameter ; inline
: reverse-each-parameter ( parameters quot -- )
3array ;
: alien-invoke-dlsym ( params -- symbols dll )
- [ dup abi>> "stdcall" = [ stdcall-mangle ] [ function>> ] if ]
+ [ dup abi>> stdcall = [ stdcall-mangle ] [ function>> ] if ]
[ library>> load-library ]
bi 2dup check-dlsym ;
USING: accessors alien alien.c-types alien.libraries
alien.syntax arrays classes.struct combinators
-compiler continuations effects io io.backend io.pathnames
-io.streams.string kernel math memory namespaces
-namespaces.private parser quotations sequences
-specialized-arrays stack-checker stack-checker.errors
-system threads tools.test words alien.complex concurrency.promises ;
+compiler continuations effects generalizations io
+io.backend io.pathnames io.streams.string kernel
+math memory namespaces namespaces.private parser
+quotations sequences specialized-arrays stack-checker
+stack-checker.errors system threads tools.test words
+alien.complex concurrency.promises ;
FROM: alien.c-types => float short ;
+FROM: alien.private => fastcall ;
SPECIALIZED-ARRAY: float
SPECIALIZED-ARRAY: char
IN: compiler.tests.alien
{ [ os unix? ] [ "libfactor-ffi-test.so" ] }
} cond append-path ;
-"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
+"f-cdecl" libfactor-ffi-tests-path cdecl add-library
-"f-stdcall" libfactor-ffi-tests-path "stdcall" add-library
+"f-stdcall" libfactor-ffi-tests-path stdcall add-library
+
+"f-fastcall" libfactor-ffi-tests-path fastcall add-library
>>
LIBRARY: f-cdecl
[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with
: indirect-test-1 ( ptr -- result )
- int { } "cdecl" alien-indirect ;
+ int { } cdecl alien-indirect ;
{ 1 1 } [ indirect-test-1 ] must-infer-as
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
: indirect-test-1' ( ptr -- )
- int { } "cdecl" alien-indirect drop ;
+ int { } cdecl alien-indirect drop ;
{ 1 0 } [ indirect-test-1' ] must-infer-as
[ -1 indirect-test-1 ] must-fail
: indirect-test-2 ( x y ptr -- result )
- int { int int } "cdecl" alien-indirect gc ;
+ int { int int } cdecl alien-indirect gc ;
{ 3 1 } [ indirect-test-2 ] must-infer-as
unit-test
: indirect-test-3 ( a b c d ptr -- result )
- int { int int int int } "stdcall" alien-indirect
+ int { int int int int } stdcall alien-indirect
gc ;
[ f ] [ "f-stdcall" load-library f = ] unit-test
-[ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
+[ stdcall ] [ "f-stdcall" library abi>> ] unit-test
: ffi_test_18 ( w x y z -- int )
int "f-stdcall" "ffi_test_18" { int int int int }
11 6 -7 ffi_test_19 [ x>> ] [ y>> ] [ z>> ] tri
] unit-test
+: multi_ffi_test_18 ( w x y z w' x' y' z' -- int int )
+ [ int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke ]
+ 4 ndip
+ int "f-stdcall" "ffi_test_18" { int int int int } alien-invoke
+ gc ;
+
+[ 25 85 ] [ 2 3 4 5 6 7 8 9 multi_ffi_test_18 ] unit-test
+
FUNCTION: double ffi_test_6 float x float y ;
[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test
[ "a" "b" ffi_test_6 ] must-fail
! Test callbacks
-: callback-1 ( -- callback ) void { } "cdecl" [ ] alien-callback ;
+: callback-1 ( -- callback ) void { } cdecl [ ] alien-callback ;
[ 0 1 ] [ [ callback-1 ] infer [ in>> length ] [ out>> length ] bi ] unit-test
[ t ] [ callback-1 alien? ] unit-test
-: callback_test_1 ( ptr -- ) void { } "cdecl" alien-indirect ;
+: callback_test_1 ( ptr -- ) void { } cdecl alien-indirect ;
[ ] [ callback-1 callback_test_1 ] unit-test
-: callback-2 ( -- callback ) void { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ;
+: callback-2 ( -- callback ) void { } cdecl [ [ 5 throw ] ignore-errors ] alien-callback ;
[ ] [ callback-2 callback_test_1 ] unit-test
-: callback-3 ( -- callback ) void { } "cdecl" [ 5 "x" set ] alien-callback ;
+: callback-3 ( -- callback ) void { } cdecl [ 5 "x" set ] alien-callback ;
[ t 3 5 ] [
[
] unit-test
: callback-5 ( -- callback )
- void { } "cdecl" [ gc ] alien-callback ;
+ void { } cdecl [ gc ] alien-callback ;
[ "testing" ] [
"testing" callback-5 callback_test_1
] unit-test
: callback-5b ( -- callback )
- void { } "cdecl" [ compact-gc ] alien-callback ;
+ void { } cdecl [ compact-gc ] alien-callback ;
[ "testing" ] [
"testing" callback-5b callback_test_1
] unit-test
: callback-6 ( -- callback )
- void { } "cdecl" [ [ continue ] callcc0 ] alien-callback ;
+ void { } cdecl [ [ continue ] callcc0 ] alien-callback ;
[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test
: callback-7 ( -- callback )
- void { } "cdecl" [ 1000000 sleep ] alien-callback ;
+ void { } cdecl [ 1000000 sleep ] alien-callback ;
[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test
[ f ] [ namespace global eq? ] unit-test
: callback-8 ( -- callback )
- void { } "cdecl" [ [ ] in-thread yield ] alien-callback ;
+ void { } cdecl [ [ ] in-thread yield ] alien-callback ;
[ ] [ callback-8 callback_test_1 ] unit-test
: callback-9 ( -- callback )
- int { int int int } "cdecl" [
+ int { int int int } cdecl [
+ + 1 +
] alien-callback ;
} cleave ;
: double-rect-callback ( -- alien )
- void { void* void* double-rect } "cdecl"
+ void { void* void* double-rect } cdecl
[ "example" set-global 2drop ] alien-callback ;
-: double-rect-test ( arg callback -- arg' )
+: double-rect-test ( arg -- arg' )
- f f rot
+ [ f f ] 2dip
- void { void* void* double-rect } "cdecl" alien-indirect
+ double-rect-callback
+ void { void* void* double-rect } cdecl alien-indirect
"example" get-global ;
[ 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
+ [
+ 1.0 2.0 3.0 4.0 <double-rect>
+ double-rect-callback double-rect-test
+ >double-rect<
+ ] unit-test
STRUCT: test_struct_14
{ x1 double }
] unit-test
: callback-10 ( -- callback )
- test_struct_14 { double double } "cdecl"
+ test_struct_14 { double double } cdecl
[
test_struct_14 <struct>
swap >>x2
] alien-callback ;
: callback-10-test ( x1 x2 callback -- result )
- test_struct_14 { double double } "cdecl" alien-indirect ;
+ test_struct_14 { double double } cdecl alien-indirect ;
[ 1.0 2.0 ] [
1.0 2.0 callback-10 callback-10-test
] unit-test
: callback-11 ( -- callback )
- test-struct-12 { int double } "cdecl"
+ test-struct-12 { int double } cdecl
[
test-struct-12 <struct>
swap >>x
] alien-callback ;
: callback-11-test ( x1 x2 callback -- result )
- test-struct-12 { int double } "cdecl" alien-indirect ;
+ test-struct-12 { int double } cdecl alien-indirect ;
[ 1 2.0 ] [
1 2.0 callback-11 callback-11-test
[ 1.0 2.0 ] [ 1.0 2.0 ffi_test_42 [ x>> ] [ y>> ] bi ] unit-test
: callback-12 ( -- callback )
- test_struct_15 { float float } "cdecl"
+ test_struct_15 { float float } cdecl
[
test_struct_15 <struct>
swap >>y
] alien-callback ;
: callback-12-test ( x1 x2 callback -- result )
- test_struct_15 { float float } "cdecl" alien-indirect ;
+ test_struct_15 { float float } cdecl alien-indirect ;
[ 1.0 2.0 ] [
1.0 2.0 callback-12 callback-12-test [ x>> ] [ y>> ] bi
[ 1.0 2 ] [ 1.0 2 ffi_test_43 [ x>> ] [ a>> ] bi ] unit-test
: callback-13 ( -- callback )
- test_struct_16 { float int } "cdecl"
+ test_struct_16 { float int } cdecl
[
test_struct_16 <struct>
swap >>a
] alien-callback ;
: callback-13-test ( x1 x2 callback -- result )
- test_struct_16 { float int } "cdecl" alien-indirect ;
+ test_struct_16 { float int } cdecl alien-indirect ;
[ 1.0 2 ] [
1.0 2 callback-13 callback-13-test
! Test interaction between threads and callbacks
: thread-callback-1 ( -- callback )
- int { } "cdecl" [ yield 100 ] alien-callback ;
+ int { } cdecl [ yield 100 ] alien-callback ;
: thread-callback-2 ( -- callback )
- int { } "cdecl" [ yield 200 ] alien-callback ;
+ int { } cdecl [ yield 200 ] alien-callback ;
: thread-callback-invoker ( callback -- n )
- int { } "cdecl" alien-indirect ;
+ int { } cdecl alien-indirect ;
<promise> "p" set
[ thread-callback-1 thread-callback-invoker "p" get fulfill ] in-thread
[ this_does_not_exist ] [ { "kernel-error" 9 f f } = ] must-fail-with
! More alien-assembly tests are in cpu.* vocabs
-: assembly-test-1 ( -- ) void { } "cdecl" [ ] alien-assembly ;
+: assembly-test-1 ( -- ) void { } cdecl [ ] alien-assembly ;
[ ] [ assembly-test-1 ] unit-test
+
+[ f ] [ "f-fastcall" load-library f = ] unit-test
+[ fastcall ] [ "f-fastcall" library abi>> ] unit-test
+
+: ffi_test_49 ( x -- int )
+ int "f-fastcall" "ffi_test_49" { int }
+ alien-invoke gc ;
+: ffi_test_50 ( x y -- int )
+ int "f-fastcall" "ffi_test_50" { int int }
+ alien-invoke gc ;
+: ffi_test_51 ( x y z -- int )
+ int "f-fastcall" "ffi_test_51" { int int int }
+ alien-invoke gc ;
+: multi_ffi_test_51 ( x y z x' y' z' -- int int )
+ [ int "f-fastcall" "ffi_test_51" { int int int } alien-invoke ]
+ 3dip
+ int "f-fastcall" "ffi_test_51" { int int int } alien-invoke gc ;
+
+[ 4 ] [ 3 ffi_test_49 ] unit-test
+[ 8 ] [ 3 4 ffi_test_50 ] unit-test
+[ 13 ] [ 3 4 5 ffi_test_51 ] unit-test
+[ 13 22 ] [ 3 4 5 6 7 8 multi_ffi_test_51 ] unit-test
+
+: ffi_test_52 ( x y z -- int )
+ int "f-fastcall" "ffi_test_52" { int float int }
+ alien-invoke gc ;
+: ffi_test_53 ( x y z w -- int )
+ int "f-fastcall" "ffi_test_53" { int float int int }
+ alien-invoke gc ;
+: ffi_test_57 ( x y -- test-struct-11 )
+ test-struct-11 "f-fastcall" "ffi_test_57" { int int }
+ alien-invoke gc ;
+: ffi_test_58 ( x y z -- test-struct-11 )
+ test-struct-11 "f-fastcall" "ffi_test_58" { int int int }
+ alien-invoke gc ;
+
+[ 13 ] [ 3 4.0 5 ffi_test_52 ] unit-test
+[ 19 ] [ 3 4.0 5 6 ffi_test_53 ] unit-test
+[ S{ test-struct-11 f 7 -1 } ] [ 3 4 ffi_test_57 ] unit-test
+[ S{ test-struct-11 f 7 -3 } ] [ 3 4 7 ffi_test_58 ] unit-test
+
+: fastcall-ii-indirect ( x y ptr -- result )
+ int { int int } fastcall alien-indirect ;
+: fastcall-iii-indirect ( x y z ptr -- result )
+ int { int int int } fastcall alien-indirect ;
+: fastcall-ifi-indirect ( x y z ptr -- result )
+ int { int float int } fastcall alien-indirect ;
+: fastcall-ifii-indirect ( x y z w ptr -- result )
+ int { int float int int } fastcall alien-indirect ;
+: fastcall-struct-return-ii-indirect ( x y ptr -- result )
+ test-struct-11 { int int } fastcall alien-indirect ;
+: fastcall-struct-return-iii-indirect ( x y z ptr -- result )
+ test-struct-11 { int int int } fastcall alien-indirect ;
+
+[ 8 ] [ 3 4 &: ffi_test_50 fastcall-ii-indirect ] unit-test
+[ 13 ] [ 3 4 5 &: ffi_test_51 fastcall-iii-indirect ] unit-test
+[ 13 ] [ 3 4.0 5 &: ffi_test_52 fastcall-ifi-indirect ] unit-test
+[ 19 ] [ 3 4.0 5 6 &: ffi_test_53 fastcall-ifii-indirect ] unit-test
+
+[ S{ test-struct-11 f 7 -1 } ]
+[ 3 4 &: ffi_test_57 fastcall-struct-return-ii-indirect ] unit-test
+
+[ S{ test-struct-11 f 7 -3 } ]
+[ 3 4 7 &: ffi_test_58 fastcall-struct-return-iii-indirect ] unit-test
+
+: fastcall-ii-callback ( -- ptr )
+ int { int int } fastcall [ + 1 + ] alien-callback ;
+: fastcall-iii-callback ( -- ptr )
+ int { int int int } fastcall [ + + 1 + ] alien-callback ;
+: fastcall-ifi-callback ( -- ptr )
+ int { int float int } fastcall
+ [ [ >integer ] dip + + 1 + ] alien-callback ;
+: fastcall-ifii-callback ( -- ptr )
+ int { int float int int } fastcall
+ [ [ >integer ] 2dip + + + 1 + ] alien-callback ;
+: fastcall-struct-return-ii-callback ( -- ptr )
+ test-struct-11 { int int } fastcall
+ [ [ + ] [ - ] 2bi test-struct-11 <struct-boa> ] alien-callback ;
+: fastcall-struct-return-iii-callback ( -- ptr )
+ test-struct-11 { int int int } fastcall
+ [ [ drop + ] [ - nip ] 3bi test-struct-11 <struct-boa> ] alien-callback ;
+
+[ 8 ] [ 3 4 fastcall-ii-callback fastcall-ii-indirect ] unit-test
+[ 13 ] [ 3 4 5 fastcall-iii-callback fastcall-iii-indirect ] unit-test
+[ 13 ] [ 3 4.0 5 fastcall-ifi-callback fastcall-ifi-indirect ] unit-test
+[ 19 ] [ 3 4.0 5 6 fastcall-ifii-callback fastcall-ifii-indirect ] unit-test
+
+[ S{ test-struct-11 f 7 -1 } ]
+[ 3 4 fastcall-struct-return-ii-callback fastcall-struct-return-ii-indirect ] unit-test
+
+[ S{ test-struct-11 f 7 -3 } ]
+[ 3 4 7 fastcall-struct-return-iii-callback fastcall-struct-return-iii-indirect ] unit-test
HOOK: %set-alien-vector cpu ( ptr offset value rep -- )
HOOK: %alien-global cpu ( dst symbol library -- )
- HOOK: %vm-field cpu ( dst fieldname -- )
- HOOK: %vm-field-ptr cpu ( dst fieldname -- )
+ HOOK: %vm-field cpu ( dst offset -- )
+ HOOK: %set-vm-field cpu ( src offset -- )
+
+ : %context ( dst -- ) 0 %vm-field ;
HOOK: %allot cpu ( dst size class temp -- )
HOOK: %write-barrier cpu ( src slot temp1 temp2 -- )
GENERIC: return-reg ( reg-class -- reg )
! Sequence of registers used for parameter passing in class
-GENERIC: param-regs ( reg-class -- regs )
+GENERIC# param-regs 1 ( reg-class abi -- regs )
-M: stack-params param-regs drop f ;
+M: stack-params param-regs 2drop f ;
-GENERIC: param-reg ( n reg-class -- reg )
+GENERIC# param-reg 1 ( n reg-class abi -- reg )
M: reg-class param-reg param-regs nth ;
-M: stack-params param-reg drop ;
+M: stack-params param-reg 2drop ;
! Is this integer small enough to be an immediate operand for
! %add-imm, %sub-imm, and %mul-imm?
! %and-imm, %or-imm, and %xor-imm?
HOOK: immediate-bitwise? cpu ( n -- ? )
+! 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 -- ? )
: %load-vm-addr ( reg -- ) vm-reg MR ;
- M: ppc %vm-field ( dst field -- )
- [ vm-reg ] dip vm-field-offset LWZ ;
+ M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip LWZ ;
- M: ppc %vm-field-ptr ( dst field -- )
- [ vm-reg ] dip vm-field-offset ADDI ;
+ M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip STW ;
GENERIC: loc-reg ( loc -- reg )
M: integer float-function-param* FMR ;
: float-function-param ( i src -- )
- [ float-regs param-regs nth ] dip float-function-param* ;
+ [ float-regs cdecl param-regs nth ] dip float-function-param* ;
: float-function-return ( reg -- )
float-regs return-reg double-rep %copy ;
M: ppc %set-alien-double -rot STFD ;
: load-zone-ptr ( reg -- )
- "nursery" %vm-field-ptr ;
+ vm-reg "nursery" vm-field-offset ADDI ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
} case ;
: next-param@ ( n -- reg x )
- 2 1 stack-frame get total-size>> LWZ
- [ 2 ] dip param@ ;
+ [ 17 ] dip param@ ;
: store-to-frame ( src n rep -- )
{
M: ppc %loop-entry ;
M: int-regs return-reg drop 3 ;
-M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ;
+M: int-regs param-regs 2drop { 3 4 5 6 7 8 9 10 } ;
M: float-regs return-reg drop 1 ;
M:: ppc %save-param-reg ( stack reg rep -- )
int-regs return-reg ds-reg 0 STW ;
M: ppc %push-context-stack ( -- )
- 11 "ctx" %vm-field
+ 11 %context
12 11 "datastack" context-field-offset LWZ
12 12 4 ADDI
12 11 "datastack" context-field-offset STW
int-regs return-reg 12 0 STW ;
M: ppc %pop-context-stack ( -- )
- 11 "ctx" %vm-field
+ 11 %context
12 11 "datastack" context-field-offset LWZ
int-regs return-reg 12 0 LWZ
12 12 4 SUBI
! If the source is a stack location, load it into freg #0.
! If the source is f, then we assume the value is already in
! freg #0.
- n [ 0 rep reg-class-of param-reg rep %load-param-reg ] when*
+ n [ 0 rep reg-class-of cdecl param-reg rep %load-param-reg ] when*
rep double-rep? 5 4 ? %load-vm-addr
func f %alien-invoke ;
"from_value_struct" f %alien-invoke ;
M:: ppc %restore-context ( temp1 temp2 -- )
- temp1 "ctx" %vm-field
+ temp1 %context
ds-reg temp1 "datastack" context-field-offset LWZ
rs-reg temp1 "retainstack" context-field-offset LWZ ;
M:: ppc %save-context ( temp1 temp2 -- )
- temp1 "ctx" %vm-field
+ temp1 %context
1 temp1 "callstack-top" context-field-offset STW
ds-reg temp1 "datastack" context-field-offset STW
rs-reg temp1 "retainstack" context-field-offset STW ;
M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
+M: ppc struct-return-pointer-type void* ;
+
M: ppc return-struct-in-registers? ( c-type -- ? )
c-type return-in-registers?>> ;
M: ppc %end-callback ( -- )
3 %load-vm-addr
- "unnest_context" f %alien-invoke ;
+ "end_callback" f %alien-invoke ;
M: ppc %end-callback-value ( ctype -- )
! Save top of data stack
- 12 ds-reg 0 LWZ
+ 16 ds-reg 0 LWZ
%end-callback
! Restore top of data stack
- 3 12 MR
+ 3 16 MR
! Unbox former top of data stack to return registers
unbox-return ;
! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: locals alien.c-types alien.libraries alien.syntax arrays
-kernel fry math namespaces sequences system layouts io
-vocabs.loader accessors init combinators command-line make
-compiler compiler.units compiler.constants compiler.alien
+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 compiler compiler.units compiler.constants compiler.alien
compiler.codegen 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 ;
+FROM: alien.private => fastcall ;
IN: cpu.x86.32
M: x86.32 machine-registers
0 MOV 0 rc-absolute-cell rel-vm ;
M: x86.32 %vm-field ( dst field -- )
- [ 0 [] MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
+ [ 0 [] MOV ] dip rc-absolute-cell rel-vm ;
+
+ M: x86.32 %set-vm-field ( dst field -- )
+ [ 0 [] swap MOV ] dip rc-absolute-cell rel-vm ;
M: x86.32 %vm-field-ptr ( dst field -- )
- [ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
+ [ 0 MOV ] dip rc-absolute-cell rel-vm ;
: local@ ( n -- op )
stack-frame get extra-stack-space dup 16 assert= + stack@ ;
M: x86.32 pic-tail-reg EBX ;
-M: x86.32 reserved-stack-space 4 cells ;
+M: x86.32 reserved-stack-space 0 ;
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
: struct-return@ ( n -- operand )
[ next-stack@ ] [ stack-frame get params>> local@ ] if* ;
-! On x86, parameters are never passed in registers.
+! 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: int-regs param-regs drop { } ;
-M: float-regs param-regs drop { } ;
+M: float-regs param-regs 2drop { } ;
+
+M: int-regs param-regs
+ nip {
+ { thiscall [ { ECX } ] }
+ { fastcall [ { ECX EDX } ] }
+ [ drop { } ]
+ } case ;
GENERIC: load-return-reg ( src rep -- )
GENERIC: store-return-reg ( dst rep -- )
+M: stack-params load-return-reg drop EAX swap MOV ;
+M: stack-params store-return-reg drop EAX MOV ;
+
M: int-rep load-return-reg drop EAX swap MOV ;
M: int-rep store-return-reg drop EAX MOV ;
M: x86.32 %prepare-jump
pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
-M: x86.32 %load-param-reg
- stack-params assert=
- [ [ EAX ] dip local@ MOV ] dip
- stack@ EAX MOV ;
+M: stack-params copy-register*
+ drop
+ {
+ { [ dup integer? ] [ EAX swap next-stack@ MOV EAX MOV ] }
+ { [ over integer? ] [ EAX swap MOV param@ EAX MOV ] }
+ } cond ;
+
+M: x86.32 %save-param-reg
+ dup stack-params? [ 3drop ] [ [ param@ ] 2dip %copy ] if ;
-M: x86.32 %save-param-reg 3drop ;
+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
EAX swap ds-reg reg-stack MOV ;
M: x86.32 %pop-context-stack ( -- )
- temp-reg "ctx" %vm-field
+ temp-reg %context
EAX temp-reg "datastack" context-field-offset [+] MOV
EAX EAX [] MOV
temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
M: x86.32 %begin-callback ( -- )
0 save-vm-ptr
+ ESP 4 [+] 0 MOV
"begin_callback" f %alien-invoke ;
M: x86.32 %alien-callback ( quot -- )
func "libm" load-library %alien-invoke
dst float-function-return ;
-: stdcall? ( params -- ? )
- abi>> "stdcall" = ;
-
: funny-large-struct-return? ( params -- ? )
#! MINGW ABI incompatibility disaster
[ return>> large-struct? ]
- [ abi>> "mingw" = os windows? not or ]
+ [ abi>> mingw = os windows? not or ]
bi and ;
+: callee-cleanup? ( abi -- ? )
+ { stdcall fastcall thiscall } member? ;
+
+: stack-arg-size ( params -- n )
+ dup abi>> '[
+ alien-parameters flatten-value-types
+ [ _ alloc-parameter 2drop ] each
+ stack-params get
+ ] with-param-regs ;
+
M: x86.32 %cleanup ( params -- )
- #! a) If we just called an stdcall function in Windows, it
+ #! a) If we just called a stdcall function in Windows, it
#! cleaned up the stack frame for us. But we don't want that
#! so we 'undo' the cleanup since we do that in %epilogue.
#! b) If we just called a function returning a struct, we
#! have to fix ESP.
{
- { [ dup stdcall? ] [ drop ESP stack-frame get params>> SUB ] }
+ { [ dup abi>> callee-cleanup? ] [ stack-arg-size ESP swap SUB ] }
{ [ dup funny-large-struct-return? ] [ drop EAX PUSH ] }
[ drop ]
} cond ;
} cond ;
! Dreadful
-M: object flatten-value-type (flatten-int-type) ;
+M: object flatten-value-type (flatten-stack-type) ;
+M: struct-c-type flatten-value-type (flatten-stack-type) ;
+M: long-long-type flatten-value-type (flatten-stack-type) ;
+M: c-type flatten-value-type
+ dup rep>> int-rep? [ (flatten-int-type) ] [ (flatten-stack-type) ] if ;
+
+M: x86.32 struct-return-pointer-type (stack-value) ;
check-sse
FROM: layouts => cell cells ;
IN: cpu.x86.64
-: param-reg-0 ( -- reg ) 0 int-regs param-reg ; inline
-: param-reg-1 ( -- reg ) 1 int-regs param-reg ; inline
-: param-reg-2 ( -- reg ) 2 int-regs param-reg ; inline
-: param-reg-3 ( -- reg ) 3 int-regs param-reg ; inline
+: param-reg-0 ( -- reg ) 0 int-regs cdecl param-reg ; inline
+: param-reg-1 ( -- reg ) 1 int-regs cdecl param-reg ; inline
+: param-reg-2 ( -- reg ) 2 int-regs cdecl param-reg ; inline
+: param-reg-3 ( -- reg ) 3 int-regs cdecl param-reg ; inline
M: x86.64 pic-tail-reg RBX ;
M: x86.64 %mov-vm-ptr ( reg -- )
vm-reg MOV ;
- M: x86.64 %vm-field ( dst field -- )
- [ vm-reg ] dip vm-field-offset [+] MOV ;
+ M: x86.64 %vm-field ( dst offset -- )
+ [ vm-reg ] dip [+] MOV ;
- M: x86.64 %vm-field-ptr ( dst field -- )
- [ vm-reg ] dip vm-field-offset [+] LEA ;
+ M: x86.64 %set-vm-field ( src offset -- )
+ [ vm-reg ] dip [+] swap MOV ;
+
+ M: x86.64 %vm-field-ptr ( dst offset -- )
+ [ vm-reg ] dip [+] LEA ;
-: param@ ( n -- op ) reserved-stack-space + stack@ ;
-
M: x86.64 %prologue ( n -- )
- temp-reg -7 [] LEA
+ temp-reg -7 [RIP+] LEA
dup PUSH
temp-reg PUSH
stack-reg swap 3 cells - SUB ;
M: x86.64 %prepare-jump
- pic-tail-reg xt-tail-pic-offset [] LEA ;
+ pic-tail-reg xt-tail-pic-offset [RIP+] LEA ;
: load-cards-offset ( dst -- )
0 MOV rc-absolute-cell rel-cards-offset ;
param-reg-0 swap ds-reg reg-stack MOV ;
M: x86.64 %pop-context-stack ( -- )
- temp-reg "ctx" %vm-field
+ temp-reg %context
param-reg-0 temp-reg "datastack" context-field-offset [+] MOV
param-reg-0 param-reg-0 [] MOV
temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
"to_value_struct" f %alien-invoke ;
: load-return-value ( rep -- )
- [ [ 0 ] dip reg-class-of param-reg ]
+ [ [ 0 ] dip reg-class-of cdecl param-reg ]
[ reg-class-of return-reg ]
[ ]
tri %copy ;
M:: x86.64 %box ( n rep func -- )
n [
n
- 0 rep reg-class-of param-reg
+ 0 rep reg-class-of cdecl param-reg
rep %load-param-reg
] [
rep load-return-value
M: x86.64 %begin-callback ( -- )
param-reg-0 %mov-vm-ptr
+ param-reg-1 0 MOV
"begin_callback" f %alien-invoke ;
M: x86.64 %alien-callback ( quot -- )
unbox-return ;
: float-function-param ( i src -- )
- [ float-regs param-regs nth ] dip double-rep %copy ;
+ [ float-regs cdecl param-regs nth ] dip double-rep %copy ;
: float-function-return ( reg -- )
float-regs return-reg double-rep %copy ;
! Call GC
"inline_gc" f %alien-invoke ;
+M: x86.64 struct-return-pointer-type void* ;
+
! The result of reading 4 bytes from memory is a fixnum on
! x86-64.
enable-alien-4-intrinsics
: gc-root@ ( n -- op ) gc-root-offset special@ ;
+: param@ ( n -- op ) reserved-stack-space + stack@ ;
+
: decr-stack-reg ( n -- )
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
HOOK: %mov-vm-ptr cpu ( reg -- )
+ HOOK: %vm-field-ptr cpu ( reg offset -- )
+
+ : load-zone-offset ( nursery-ptr -- )
+ "nursery" vm-field-offset %vm-field-ptr ;
+
: load-allot-ptr ( nursery-ptr allot-ptr -- )
- [ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ;
+ [ drop load-zone-offset ] [ swap [] MOV ] 2bi ;
: inc-allot-ptr ( nursery-ptr n -- )
[ [] ] dip data-alignment get align ADD ;
M: x86 %write-barrier-imm ( src slot temp1 temp2 -- ) (%write-barrier) ;
M:: x86 %check-nursery ( label size temp1 temp2 -- )
- temp1 "nursery" %vm-field-ptr
+ temp1 load-zone-offset
! Load 'here' into temp2
temp2 temp1 [] MOV
temp2 size ADD
ds-reg [] int-regs return-reg MOV ;
M: x86 %push-context-stack ( -- )
- temp-reg "ctx" %vm-field
+ temp-reg %context
temp-reg "datastack" context-field-offset [+] bootstrap-cell ADD
temp-reg temp-reg "datastack" context-field-offset [+] MOV
temp-reg [] int-regs return-reg MOV ;
M:: x86 %restore-context ( temp1 temp2 -- )
#! Load Factor stack pointers on entry from C to Factor.
- temp1 "ctx" %vm-field
+ temp1 %context
ds-reg temp1 "datastack" context-field-offset [+] MOV
rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
- temp1 "ctx" %vm-field
+ temp1 %context
temp2 stack-reg cell neg [+] LEA
temp1 "callstack-top" context-field-offset [+] temp2 MOV
temp1 "datastack" context-field-offset [+] ds-reg MOV
projects / factor.git / commitdiff