Merge branch 'master' into startup
Doug Coleman
commit
f2b159529c
|
|
@ -1,18 +1,19 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.data alien.strings parser
|
||||
threads words kernel.private kernel io.encodings.utf8 eval ;
|
||||
USING: accessors alien alien.c-types alien.data alien.strings
|
||||
parser threads words kernel.private kernel io.encodings.utf8
|
||||
eval ;
|
||||
IN: alien.remote-control
|
||||
|
||||
: eval-callback ( -- callback )
|
||||
"void*" { "char*" } "cdecl"
|
||||
void* { char* } "cdecl"
|
||||
[ eval>string utf8 malloc-string ] alien-callback ;
|
||||
|
||||
: yield-callback ( -- callback )
|
||||
"void" { } "cdecl" [ yield ] alien-callback ;
|
||||
void { } "cdecl" [ yield ] alien-callback ;
|
||||
|
||||
: sleep-callback ( -- callback )
|
||||
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
|
||||
void { long } "cdecl" [ sleep ] alien-callback ;
|
||||
|
||||
: ?callback ( word -- alien )
|
||||
dup optimized? [ execute ] [ drop f ] if ; inline
|
||||
|
|
|
|||
|
|
@ -9,10 +9,10 @@ IN: compiler.alien
|
|||
|
||||
: alien-parameters ( params -- seq )
|
||||
dup parameters>>
|
||||
swap return>> large-struct? [ "void*" prefix ] when ;
|
||||
swap return>> large-struct? [ void* prefix ] when ;
|
||||
|
||||
: alien-return ( params -- ctype )
|
||||
return>> dup large-struct? [ drop "void" ] when ;
|
||||
return>> dup large-struct? [ drop void ] when ;
|
||||
|
||||
: c-type-stack-align ( type -- align )
|
||||
dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
|
||||
|
|
@ -20,8 +20,7 @@ IN: compiler.alien
|
|||
: parameter-align ( n type -- n delta )
|
||||
[ c-type-stack-align align dup ] [ drop ] 2bi - ;
|
||||
|
||||
: parameter-sizes ( types -- total offsets )
|
||||
#! Compute stack frame locations.
|
||||
: parameter-offsets ( types -- total offsets )
|
||||
[
|
||||
0 [
|
||||
[ parameter-align drop dup , ] keep stack-size +
|
||||
|
|
|
|||
|
|
@ -27,7 +27,9 @@ M: ##call compute-stack-frame*
|
|||
|
||||
M: ##gc compute-stack-frame*
|
||||
frame-required? on
|
||||
stack-frame new swap tagged-values>> length cells >>gc-root-size
|
||||
stack-frame new
|
||||
swap tagged-values>> length cells >>gc-root-size
|
||||
t >>calls-vm?
|
||||
request-stack-frame ;
|
||||
|
||||
M: _spill-area-size compute-stack-frame*
|
||||
|
|
|
|||
|
|
@ -212,7 +212,8 @@ M: #terminate emit-node drop ##no-tco end-basic-block ;
|
|||
stack-frame new
|
||||
swap
|
||||
[ return>> return-size >>return ]
|
||||
[ alien-parameters parameter-sizes drop >>params ] bi ;
|
||||
[ alien-parameters parameter-offsets drop >>params ] bi
|
||||
t >>calls-vm? ;
|
||||
|
||||
: alien-node-height ( params -- )
|
||||
[ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
|
||||
|
|
|
|||
|
|
@ -9,7 +9,8 @@ TUPLE: stack-frame
|
|||
{ return integer }
|
||||
{ total-size integer }
|
||||
{ gc-root-size integer }
|
||||
{ spill-area-size integer } ;
|
||||
{ spill-area-size integer }
|
||||
{ calls-vm? boolean } ;
|
||||
|
||||
! Stack frame utilities
|
||||
: param-base ( -- n )
|
||||
|
|
@ -35,7 +36,9 @@ TUPLE: stack-frame
|
|||
|
||||
: max-stack-frame ( frame1 frame2 -- frame3 )
|
||||
[ stack-frame new ] 2dip
|
||||
{
|
||||
[ [ params>> ] bi@ max >>params ]
|
||||
[ [ return>> ] bi@ max >>return ]
|
||||
[ [ gc-root-size>> ] bi@ max >>gc-root-size ]
|
||||
2tri ;
|
||||
[ [ calls-vm?>> ] bi@ or >>calls-vm? ]
|
||||
} 2cleave ;
|
||||
|
|
@ -333,35 +333,29 @@ M: reg-class reg-class-full?
|
|||
[ alloc-stack-param ] [ alloc-fastcall-param ] if
|
||||
[ param-reg ] dip ;
|
||||
|
||||
: (flatten-int-type) ( size -- seq )
|
||||
cell /i "void*" c-type <repetition> ;
|
||||
: (flatten-int-type) ( type -- seq )
|
||||
stack-size cell align cell /i void* c-type <repetition> ;
|
||||
|
||||
GENERIC: flatten-value-type ( type -- types )
|
||||
|
||||
M: object flatten-value-type 1array ;
|
||||
|
||||
M: struct-c-type flatten-value-type ( type -- types )
|
||||
stack-size cell align (flatten-int-type) ;
|
||||
|
||||
M: long-long-type flatten-value-type ( type -- types )
|
||||
stack-size cell align (flatten-int-type) ;
|
||||
M: struct-c-type flatten-value-type (flatten-int-type) ;
|
||||
M: long-long-type flatten-value-type (flatten-int-type) ;
|
||||
M: c-type-name flatten-value-type c-type flatten-value-type ;
|
||||
|
||||
: flatten-value-types ( params -- params )
|
||||
#! Convert value type structs to consecutive void*s.
|
||||
[
|
||||
0 [
|
||||
c-type
|
||||
[ parameter-align (flatten-int-type) % ] keep
|
||||
[ parameter-align cell /i void* c-type <repetition> % ] keep
|
||||
[ stack-size cell align + ] keep
|
||||
flatten-value-type %
|
||||
] reduce drop
|
||||
] { } make ;
|
||||
|
||||
: each-parameter ( parameters quot -- )
|
||||
[ [ parameter-sizes nip ] keep ] dip 2each ; inline
|
||||
|
||||
: reverse-each-parameter ( parameters quot -- )
|
||||
[ [ parameter-sizes nip ] keep ] dip 2reverse-each ; inline
|
||||
[ [ parameter-offsets nip ] keep ] dip 2each ; inline
|
||||
|
||||
: reset-fastcall-counts ( -- )
|
||||
{ int-regs float-regs stack-params } [ 0 swap set ] each ;
|
||||
|
|
@ -378,10 +372,17 @@ M: long-long-type flatten-value-type ( type -- types )
|
|||
[ '[ alloc-parameter _ execute ] ]
|
||||
bi* each-parameter ; inline
|
||||
|
||||
: reverse-each-parameter ( parameters quot -- )
|
||||
[ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline
|
||||
|
||||
: prepare-unbox-parameters ( parameters -- offsets types indices )
|
||||
[ parameter-offsets nip ] [ ] [ length iota reverse ] tri ;
|
||||
|
||||
: unbox-parameters ( offset node -- )
|
||||
parameters>> [
|
||||
%prepare-unbox [ over + ] dip unbox-parameter
|
||||
] reverse-each-parameter drop ;
|
||||
parameters>> swap
|
||||
'[ prepare-unbox-parameters [ %prepare-unbox [ _ + ] dip unbox-parameter ] 3each ]
|
||||
[ length neg %inc-d ]
|
||||
bi ;
|
||||
|
||||
: prepare-box-struct ( node -- offset )
|
||||
#! Return offset on C stack where to store unboxed
|
||||
|
|
@ -413,7 +414,7 @@ M: long-long-type flatten-value-type ( type -- types )
|
|||
] if ;
|
||||
|
||||
: stdcall-mangle ( symbol params -- symbol )
|
||||
parameters>> parameter-sizes drop number>string "@" glue ;
|
||||
parameters>> parameter-offsets drop number>string "@" glue ;
|
||||
|
||||
: alien-invoke-dlsym ( params -- symbols dll )
|
||||
[ [ function>> dup ] keep stdcall-mangle 2array ]
|
||||
|
|
|
|||
|
|
@ -463,7 +463,7 @@ HOOK: dummy-int-params? cpu ( -- ? )
|
|||
! If t, all int parameters are shadowed by dummy FP parameters
|
||||
HOOK: dummy-fp-params? cpu ( -- ? )
|
||||
|
||||
HOOK: %prepare-unbox cpu ( -- )
|
||||
HOOK: %prepare-unbox cpu ( n -- )
|
||||
|
||||
HOOK: %unbox cpu ( n rep func -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -577,10 +577,8 @@ M:: ppc %save-param-reg ( stack reg rep -- )
|
|||
M:: ppc %load-param-reg ( stack reg rep -- )
|
||||
reg stack local@ rep load-from-frame ;
|
||||
|
||||
M: ppc %prepare-unbox ( -- )
|
||||
! First parameter is top of stack
|
||||
3 ds-reg 0 LWZ
|
||||
ds-reg dup cell SUBI ;
|
||||
M: ppc %prepare-unbox ( n -- )
|
||||
[ 3 ] dip <ds-loc> loc>operand LWZ ;
|
||||
|
||||
M: ppc %unbox ( n rep func -- )
|
||||
! Value must be in r3
|
||||
|
|
|
|||
|
|
@ -25,6 +25,11 @@ M: x86.32 rs-reg EDI ;
|
|||
M: x86.32 stack-reg ESP ;
|
||||
M: x86.32 temp-reg ECX ;
|
||||
|
||||
: local@ ( n -- op )
|
||||
stack-frame get extra-stack-space dup 16 assert= + stack@ ;
|
||||
|
||||
M: x86.32 extra-stack-space calls-vm?>> 16 0 ? ;
|
||||
|
||||
M: x86.32 %mark-card
|
||||
drop HEX: ffffffff [+] card-mark <byte> MOV
|
||||
building get pop
|
||||
|
|
@ -57,12 +62,12 @@ M:: x86.32 %dispatch ( src temp -- )
|
|||
|
||||
M: x86.32 pic-tail-reg EBX ;
|
||||
|
||||
M: x86.32 reserved-area-size 0 ;
|
||||
M: x86.32 reserved-stack-space 4 cells ;
|
||||
|
||||
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
|
||||
|
||||
: push-vm-ptr ( -- )
|
||||
0 PUSH 0 rc-absolute-cell rel-vm ; ! push the vm ptr as an argument
|
||||
: save-vm-ptr ( n -- )
|
||||
stack@ 0 MOV 0 rc-absolute-cell rel-vm ;
|
||||
|
||||
M: x86.32 return-struct-in-registers? ( c-type -- ? )
|
||||
c-type
|
||||
|
|
@ -72,44 +77,34 @@ M: x86.32 return-struct-in-registers? ( c-type -- ? )
|
|||
and or ;
|
||||
|
||||
: struct-return@ ( n -- operand )
|
||||
[ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;
|
||||
[ next-stack@ ] [ stack-frame get params>> local@ ] if* ;
|
||||
|
||||
! On x86, parameters are never passed in registers.
|
||||
M: int-regs return-reg drop EAX ;
|
||||
M: int-regs param-regs drop { } ;
|
||||
M: float-regs param-regs drop { } ;
|
||||
|
||||
GENERIC: push-return-reg ( rep -- )
|
||||
GENERIC: load-return-reg ( n rep -- )
|
||||
GENERIC: store-return-reg ( n rep -- )
|
||||
GENERIC: load-return-reg ( src rep -- )
|
||||
GENERIC: store-return-reg ( dst rep -- )
|
||||
|
||||
M: int-rep push-return-reg drop EAX PUSH ;
|
||||
M: int-rep load-return-reg drop EAX swap next-stack@ MOV ;
|
||||
M: int-rep store-return-reg drop stack@ EAX MOV ;
|
||||
M: int-rep load-return-reg drop EAX swap MOV ;
|
||||
M: int-rep store-return-reg drop EAX MOV ;
|
||||
|
||||
M: float-rep push-return-reg drop ESP 4 SUB ESP [] FSTPS ;
|
||||
M: float-rep load-return-reg drop next-stack@ FLDS ;
|
||||
M: float-rep store-return-reg drop stack@ FSTPS ;
|
||||
M: float-rep load-return-reg drop FLDS ;
|
||||
M: float-rep store-return-reg drop FSTPS ;
|
||||
|
||||
M: double-rep push-return-reg drop ESP 8 SUB ESP [] FSTPL ;
|
||||
M: double-rep load-return-reg drop next-stack@ FLDL ;
|
||||
M: double-rep store-return-reg drop stack@ FSTPL ;
|
||||
|
||||
: align-sub ( n -- )
|
||||
[ align-stack ] keep - decr-stack-reg ;
|
||||
|
||||
: align-add ( n -- )
|
||||
align-stack incr-stack-reg ;
|
||||
|
||||
: with-aligned-stack ( n quot -- )
|
||||
'[ align-sub @ ] [ align-add ] bi ; inline
|
||||
M: double-rep load-return-reg drop FLDL ;
|
||||
M: double-rep store-return-reg drop FSTPL ;
|
||||
|
||||
M: x86.32 %prologue ( n -- )
|
||||
dup PUSH
|
||||
0 PUSH rc-absolute-cell rel-this
|
||||
3 cells - decr-stack-reg ;
|
||||
|
||||
M: x86.32 %load-param-reg 3drop ;
|
||||
M: x86.32 %load-param-reg
|
||||
stack-params assert=
|
||||
[ [ EAX ] dip local@ MOV ] dip
|
||||
stack@ EAX MOV ;
|
||||
|
||||
M: x86.32 %save-param-reg 3drop ;
|
||||
|
||||
|
|
@ -118,16 +113,14 @@ M: x86.32 %save-param-reg 3drop ;
|
|||
#! are boxing a return value of a C function. If n is an
|
||||
#! integer, push [ESP+n] on the stack; we are boxing a
|
||||
#! parameter being passed to a callback from C.
|
||||
over [ load-return-reg ] [ 2drop ] if ;
|
||||
over [ [ next-stack@ ] dip load-return-reg ] [ 2drop ] if ;
|
||||
|
||||
M:: x86.32 %box ( n rep func -- )
|
||||
n rep (%box)
|
||||
rep rep-size cell + [
|
||||
push-vm-ptr
|
||||
rep push-return-reg
|
||||
func f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
|
||||
rep rep-size save-vm-ptr
|
||||
0 stack@ rep store-return-reg
|
||||
func f %alien-invoke ;
|
||||
|
||||
: (%box-long-long) ( n -- )
|
||||
[
|
||||
EDX over next-stack@ MOV
|
||||
|
|
@ -136,56 +129,39 @@ M:: x86.32 %box ( n rep func -- )
|
|||
|
||||
M: x86.32 %box-long-long ( n func -- )
|
||||
[ (%box-long-long) ] dip
|
||||
12 [
|
||||
push-vm-ptr
|
||||
EDX PUSH
|
||||
EAX PUSH
|
||||
f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
8 save-vm-ptr
|
||||
4 stack@ EDX MOV
|
||||
0 stack@ EAX MOV
|
||||
f %alien-invoke ;
|
||||
|
||||
M:: x86.32 %box-large-struct ( n c-type -- )
|
||||
! Compute destination address
|
||||
EDX n struct-return@ LEA
|
||||
12 [
|
||||
push-vm-ptr
|
||||
! Push struct size
|
||||
c-type heap-size PUSH
|
||||
! Push destination address
|
||||
EDX PUSH
|
||||
! Copy the struct from the C stack
|
||||
"box_value_struct" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
8 save-vm-ptr
|
||||
4 stack@ c-type heap-size MOV
|
||||
0 stack@ EDX MOV
|
||||
"box_value_struct" f %alien-invoke ;
|
||||
|
||||
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 stack@ EAX MOV ;
|
||||
0 local@ EAX MOV ;
|
||||
|
||||
M: x86.32 %box-small-struct ( c-type -- )
|
||||
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
|
||||
16 [
|
||||
push-vm-ptr
|
||||
heap-size PUSH
|
||||
EDX PUSH
|
||||
EAX PUSH
|
||||
"box_small_struct" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
12 save-vm-ptr
|
||||
8 stack@ swap heap-size MOV
|
||||
4 stack@ EDX MOV
|
||||
0 stack@ EAX MOV
|
||||
"box_small_struct" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %prepare-unbox ( -- )
|
||||
#! Move top of data stack to EAX.
|
||||
EAX ESI [] MOV
|
||||
ESI 4 SUB ;
|
||||
EAX swap ds-reg reg-stack MOV ;
|
||||
|
||||
: call-unbox-func ( func -- )
|
||||
8 [
|
||||
! push the vm ptr as an argument
|
||||
push-vm-ptr
|
||||
! Push parameter
|
||||
EAX PUSH
|
||||
! Call the unboxer
|
||||
f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
4 save-vm-ptr
|
||||
0 stack@ EAX MOV
|
||||
f %alien-invoke ;
|
||||
|
||||
M: x86.32 %unbox ( n rep func -- )
|
||||
#! The value being unboxed must already be in EAX.
|
||||
|
|
@ -194,37 +170,33 @@ M: x86.32 %unbox ( n rep func -- )
|
|||
#! a parameter to a C function about to be called.
|
||||
call-unbox-func
|
||||
! Store the return value on the C stack
|
||||
over [ store-return-reg ] [ 2drop ] if ;
|
||||
over [ [ local@ ] dip store-return-reg ] [ 2drop ] if ;
|
||||
|
||||
M: x86.32 %unbox-long-long ( n func -- )
|
||||
call-unbox-func
|
||||
! Store the return value on the C stack
|
||||
[
|
||||
dup stack@ EAX MOV
|
||||
cell + stack@ EDX MOV
|
||||
[ local@ EAX MOV ]
|
||||
[ 4 + local@ EDX MOV ] bi
|
||||
] when* ;
|
||||
|
||||
: %unbox-struct-1 ( -- )
|
||||
#! Alien must be in EAX.
|
||||
8 [
|
||||
push-vm-ptr
|
||||
EAX PUSH
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load first cell
|
||||
EAX EAX [] MOV
|
||||
] with-aligned-stack ;
|
||||
4 save-vm-ptr
|
||||
0 stack@ EAX MOV
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load first cell
|
||||
EAX EAX [] MOV ;
|
||||
|
||||
: %unbox-struct-2 ( -- )
|
||||
#! Alien must be in EAX.
|
||||
8 [
|
||||
push-vm-ptr
|
||||
EAX PUSH
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load second cell
|
||||
EDX EAX 4 [+] MOV
|
||||
! Load first cell
|
||||
EAX EAX [] MOV
|
||||
] with-aligned-stack ;
|
||||
4 save-vm-ptr
|
||||
0 stack@ EAX MOV
|
||||
"alien_offset" f %alien-invoke
|
||||
! Load second cell
|
||||
EDX EAX 4 [+] MOV
|
||||
! Load first cell
|
||||
EAX EAX [] MOV ;
|
||||
|
||||
M: x86 %unbox-small-struct ( size -- )
|
||||
#! Alien must be in EAX.
|
||||
|
|
@ -236,63 +208,46 @@ M: x86 %unbox-small-struct ( size -- )
|
|||
M:: x86.32 %unbox-large-struct ( n c-type -- )
|
||||
! Alien must be in EAX.
|
||||
! Compute destination address
|
||||
EDX n stack@ LEA
|
||||
16 [
|
||||
push-vm-ptr
|
||||
! Push struct size
|
||||
c-type heap-size PUSH
|
||||
! Push destination address
|
||||
EDX PUSH
|
||||
! Push source address
|
||||
EAX PUSH
|
||||
! Copy the struct to the stack
|
||||
"to_value_struct" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
EDX n local@ LEA
|
||||
12 save-vm-ptr
|
||||
8 stack@ c-type heap-size MOV
|
||||
4 stack@ EDX MOV
|
||||
0 stack@ EAX MOV
|
||||
"to_value_struct" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %nest-stacks ( -- )
|
||||
! Save current frame. See comment in vm/contexts.hpp
|
||||
EAX stack-reg stack-frame get total-size>> 3 cells - [+] LEA
|
||||
8 [
|
||||
push-vm-ptr
|
||||
EAX PUSH
|
||||
"nest_stacks" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
4 save-vm-ptr
|
||||
0 stack@ EAX MOV
|
||||
"nest_stacks" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %unnest-stacks ( -- )
|
||||
4 [
|
||||
push-vm-ptr
|
||||
"unnest_stacks" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
0 save-vm-ptr
|
||||
"unnest_stacks" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %prepare-alien-indirect ( -- )
|
||||
4 [
|
||||
push-vm-ptr
|
||||
"unbox_alien" f %alien-invoke
|
||||
] with-aligned-stack
|
||||
0 save-vm-ptr
|
||||
"unbox_alien" f %alien-invoke
|
||||
EBP EAX MOV ;
|
||||
|
||||
M: x86.32 %alien-indirect ( -- )
|
||||
EBP CALL ;
|
||||
|
||||
M: x86.32 %alien-callback ( quot -- )
|
||||
! Fastcall
|
||||
param-reg-1 swap %load-reference
|
||||
param-reg-2 %mov-vm-ptr
|
||||
"c_to_factor" f %alien-invoke ;
|
||||
|
||||
M: x86.32 %callback-value ( ctype -- )
|
||||
! Align C stack
|
||||
ESP 12 SUB
|
||||
! Save top of data stack in non-volatile register
|
||||
%prepare-unbox
|
||||
EAX PUSH
|
||||
push-vm-ptr
|
||||
0 %prepare-unbox
|
||||
4 stack@ EAX MOV
|
||||
0 save-vm-ptr
|
||||
! Restore data/call/retain stacks
|
||||
"unnest_stacks" f %alien-invoke
|
||||
! Place top of data stack in EAX
|
||||
temp-reg POP
|
||||
EAX POP
|
||||
! Restore C stack
|
||||
ESP 12 ADD
|
||||
! Place former top of data stack back in EAX
|
||||
EAX 4 stack@ MOV
|
||||
! Unbox EAX
|
||||
unbox-return ;
|
||||
|
||||
|
|
@ -357,17 +312,11 @@ M: x86.32 %callback-return ( n -- )
|
|||
} cond RET ;
|
||||
|
||||
M:: x86.32 %call-gc ( gc-root-count temp -- )
|
||||
temp gc-root-base param@ LEA
|
||||
12 [
|
||||
! Pass the VM ptr as the third parameter
|
||||
push-vm-ptr
|
||||
! Pass number of roots as second parameter
|
||||
gc-root-count PUSH
|
||||
! Pass pointer to start of GC roots as first parameter
|
||||
temp PUSH
|
||||
! Call GC
|
||||
"inline_gc" f %alien-invoke
|
||||
] with-aligned-stack ;
|
||||
temp gc-root-base special@ LEA
|
||||
8 save-vm-ptr
|
||||
4 stack@ gc-root-count MOV
|
||||
0 stack@ temp MOV
|
||||
"inline_gc" f %alien-invoke ;
|
||||
|
||||
M: x86.32 dummy-stack-params? f ;
|
||||
|
||||
|
|
@ -375,10 +324,13 @@ M: x86.32 dummy-int-params? f ;
|
|||
|
||||
M: x86.32 dummy-fp-params? f ;
|
||||
|
||||
! Dreadful
|
||||
M: object flatten-value-type (flatten-int-type) ;
|
||||
|
||||
os windows? [
|
||||
cell "longlong" c-type (>>align)
|
||||
cell "ulonglong" c-type (>>align)
|
||||
4 "double" c-type (>>align)
|
||||
cell longlong c-type (>>align)
|
||||
cell ulonglong c-type (>>align)
|
||||
4 double c-type (>>align)
|
||||
] unless
|
||||
|
||||
check-sse
|
||||
|
|
|
|||
|
|
@ -8,6 +8,22 @@ compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.stack-frame
|
|||
cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 cpu.architecture ;
|
||||
IN: cpu.x86.64
|
||||
|
||||
: param-reg-1 ( -- reg ) int-regs param-regs first ; inline
|
||||
: param-reg-2 ( -- reg ) int-regs param-regs second ; inline
|
||||
: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
|
||||
: param-reg-4 ( -- reg ) int-regs param-regs fourth ; inline
|
||||
|
||||
M: x86.64 pic-tail-reg RBX ;
|
||||
|
||||
M: int-regs return-reg drop RAX ;
|
||||
M: float-regs return-reg drop XMM0 ;
|
||||
|
||||
M: x86.64 ds-reg R14 ;
|
||||
M: x86.64 rs-reg R15 ;
|
||||
M: x86.64 stack-reg RSP ;
|
||||
|
||||
M: x86.64 extra-stack-space drop 0 ;
|
||||
|
||||
M: x86.64 machine-registers
|
||||
{
|
||||
{ int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
|
||||
|
|
@ -17,9 +33,13 @@ M: x86.64 machine-registers
|
|||
} }
|
||||
} ;
|
||||
|
||||
M: x86.64 ds-reg R14 ;
|
||||
M: x86.64 rs-reg R15 ;
|
||||
M: x86.64 stack-reg RSP ;
|
||||
: param@ ( n -- op ) reserved-stack-space + stack@ ;
|
||||
|
||||
M: x86.64 %prologue ( n -- )
|
||||
temp-reg 0 MOV rc-absolute-cell rel-this
|
||||
dup PUSH
|
||||
temp-reg PUSH
|
||||
stack-reg swap 3 cells - SUB ;
|
||||
|
||||
: load-cards-offset ( dst -- )
|
||||
0 MOV rc-absolute-cell rel-cards-offset ;
|
||||
|
|
@ -50,22 +70,6 @@ M:: x86.64 %dispatch ( src temp -- )
|
|||
[ align-code ]
|
||||
bi ;
|
||||
|
||||
: param-reg-1 ( -- reg ) int-regs param-regs first ; inline
|
||||
: param-reg-2 ( -- reg ) int-regs param-regs second ; inline
|
||||
: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
|
||||
: param-reg-4 ( -- reg ) int-regs param-regs fourth ; inline
|
||||
|
||||
M: x86.64 pic-tail-reg RBX ;
|
||||
|
||||
M: int-regs return-reg drop RAX ;
|
||||
M: float-regs return-reg drop XMM0 ;
|
||||
|
||||
M: x86.64 %prologue ( n -- )
|
||||
temp-reg 0 MOV rc-absolute-cell rel-this
|
||||
dup PUSH
|
||||
temp-reg PUSH
|
||||
stack-reg swap 3 cells - SUB ;
|
||||
|
||||
M: stack-params copy-register*
|
||||
drop
|
||||
{
|
||||
|
|
@ -84,10 +88,8 @@ M: x86 %load-param-reg [ swap param@ ] dip %copy ;
|
|||
call
|
||||
] with-scope ; inline
|
||||
|
||||
M: x86.64 %prepare-unbox ( -- )
|
||||
! First parameter is top of stack
|
||||
param-reg-1 R14 [] MOV
|
||||
R14 cell SUB ;
|
||||
M: x86.64 %prepare-unbox ( n -- )
|
||||
param-reg-1 swap ds-reg reg-stack MOV ;
|
||||
|
||||
M:: x86.64 %unbox ( n rep func -- )
|
||||
param-reg-2 %mov-vm-ptr
|
||||
|
|
@ -217,9 +219,7 @@ M: x86.64 %alien-callback ( quot -- )
|
|||
"c_to_factor" f %alien-invoke ;
|
||||
|
||||
M: x86.64 %callback-value ( ctype -- )
|
||||
! Save top of data stack
|
||||
%prepare-unbox
|
||||
! Save top of data stack
|
||||
0 %prepare-unbox
|
||||
RSP 8 SUB
|
||||
param-reg-1 PUSH
|
||||
param-reg-1 %mov-vm-ptr
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ M: int-regs param-regs
|
|||
M: float-regs param-regs
|
||||
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
|
||||
|
||||
M: x86.64 reserved-area-size 0 ;
|
||||
M: x86.64 reserved-stack-space 0 ;
|
||||
|
||||
SYMBOL: (stack-value)
|
||||
! The ABI for passing structs by value is pretty great
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ M: int-regs param-regs drop { RCX RDX R8 R9 } ;
|
|||
|
||||
M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
|
||||
|
||||
M: x86.64 reserved-area-size 4 cells ;
|
||||
M: x86.64 reserved-stack-space 4 cells ;
|
||||
|
||||
M: x86.64 return-struct-in-registers? ( c-type -- ? )
|
||||
heap-size { 1 2 4 8 } member? ;
|
||||
|
|
|
|||
|
|
@ -24,15 +24,20 @@ M: x86 vector-regs float-regs ;
|
|||
|
||||
HOOK: stack-reg cpu ( -- reg )
|
||||
|
||||
HOOK: reserved-area-size cpu ( -- n )
|
||||
HOOK: reserved-stack-space cpu ( -- n )
|
||||
|
||||
HOOK: extra-stack-space cpu ( stack-frame -- n )
|
||||
|
||||
: stack@ ( n -- op ) stack-reg swap [+] ;
|
||||
|
||||
: param@ ( n -- op ) reserved-area-size + stack@ ;
|
||||
: special@ ( n -- op )
|
||||
stack-frame get extra-stack-space +
|
||||
reserved-stack-space +
|
||||
stack@ ;
|
||||
|
||||
: spill@ ( n -- op ) spill-offset param@ ;
|
||||
: spill@ ( n -- op ) spill-offset special@ ;
|
||||
|
||||
: gc-root@ ( n -- op ) gc-root-offset param@ ;
|
||||
: gc-root@ ( n -- op ) gc-root-offset special@ ;
|
||||
|
||||
: decr-stack-reg ( n -- )
|
||||
dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
|
||||
|
|
@ -44,7 +49,11 @@ HOOK: reserved-area-size cpu ( -- n )
|
|||
os macosx? cpu x86.64? or [ 16 align ] when ;
|
||||
|
||||
M: x86 stack-frame-size ( stack-frame -- i )
|
||||
(stack-frame-size) 3 cells reserved-area-size + + align-stack ;
|
||||
[ (stack-frame-size) ]
|
||||
[ extra-stack-space ] bi +
|
||||
reserved-stack-space +
|
||||
3 cells +
|
||||
align-stack ;
|
||||
|
||||
! Must be a volatile register not used for parameter passing, for safe
|
||||
! use in calls in and out of C
|
||||
|
|
|
|||
|
|
@ -4,5 +4,4 @@ IN: help.handbook.tests
|
|||
[ ] [ "article-index" print-topic ] unit-test
|
||||
[ ] [ "primitive-index" print-topic ] unit-test
|
||||
[ ] [ "error-index" print-topic ] unit-test
|
||||
[ ] [ "type-index" print-topic ] unit-test
|
||||
[ ] [ "class-index" print-topic ] unit-test
|
||||
|
|
|
|||
|
|
@ -239,9 +239,6 @@ ARTICLE: "primitive-index" "Primitive index"
|
|||
ARTICLE: "error-index" "Error index"
|
||||
{ $index [ all-errors ] } ;
|
||||
|
||||
ARTICLE: "type-index" "Type index"
|
||||
{ $index [ builtins get sift ] } ;
|
||||
|
||||
ARTICLE: "class-index" "Class index"
|
||||
{ $heading "Built-in classes" }
|
||||
{ $index [ classes [ builtin-class? ] filter ] }
|
||||
|
|
@ -387,7 +384,6 @@ ARTICLE: "handbook" "Factor handbook"
|
|||
"article-index"
|
||||
"primitive-index"
|
||||
"error-index"
|
||||
"type-index"
|
||||
"class-index"
|
||||
}
|
||||
{ $heading "Explore the code base" }
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays alien.c-types assocs kernel sequences math math.functions
|
||||
hints math.order math.libm fry combinators byte-arrays accessors
|
||||
locals ;
|
||||
hints math.order math.libm math.floats.private fry combinators
|
||||
byte-arrays accessors locals ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
IN: math.vectors
|
||||
|
||||
|
|
@ -29,8 +29,16 @@ M: object element-type drop f ; inline
|
|||
: [v-] ( u v -- w ) [ [-] ] 2map ;
|
||||
: v* ( u v -- w ) [ * ] 2map ;
|
||||
: v/ ( u v -- w ) [ / ] 2map ;
|
||||
: vmax ( u v -- w ) [ max ] 2map ;
|
||||
: vmin ( u v -- w ) [ min ] 2map ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: if-both-floats ( x y p q -- )
|
||||
[ 2dup [ float? ] both? ] 2dip if ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: vmax ( u v -- w ) [ [ float-max ] [ max ] if-both-floats ] 2map ;
|
||||
: vmin ( u v -- w ) [ [ float-min ] [ min ] if-both-floats ] 2map ;
|
||||
|
||||
: v+- ( u v -- w )
|
||||
[ t ] 2dip
|
||||
|
|
|
|||
|
|
@ -122,10 +122,6 @@ SPECIALIZED-ARRAY: fixed-string
|
|||
! If the C type doesn't exist, don't generate a vocab
|
||||
SYMBOL: __does_not_exist__
|
||||
|
||||
[ ] [
|
||||
[ __does_not_exist__ specialized-array-vocab forget-vocab ] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"""
|
||||
IN: specialized-arrays.tests
|
||||
|
|
@ -151,4 +147,9 @@ SPECIALIZED-ARRAY: __does_not_exist__
|
|||
deferred?
|
||||
] unit-test
|
||||
|
||||
[ \ __does_not_exist__ forget ] with-compilation-unit
|
||||
[ ] [
|
||||
[
|
||||
\ __does_not_exist__ forget
|
||||
__does_not_exist__ specialized-array-vocab forget-vocab
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: accessors assocs arrays kernel models monads sequences
|
||||
models.combinators ui.gadgets ui.gadgets.borders ui.gadgets.buttons
|
||||
ui.gadgets.buttons.private ui.gadgets.editors words images.loader
|
||||
ui.gadgets.scrollers ui.images vocabs.parser lexer
|
||||
ui.gadgets.buttons.private ui.gadgets.editors ui.gadgets.editors.private
|
||||
words images.loader ui.gadgets.scrollers ui.images vocabs.parser lexer
|
||||
models.range ui.gadgets.sliders ;
|
||||
QUALIFIED-WITH: ui.gadgets.sliders slider
|
||||
QUALIFIED-WITH: ui.gadgets.tables tbl
|
||||
|
|
|
|||
Loading…
Reference in New Issue