steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

FFI rewrite part 5: return value boxing and callback parameter boxing now uses vregs; simplify return value unboxing

db4
Slava Pestov 2010-05-16 03:43:02 -04:00
parent 0c27f30475
commit 5b48cd2a63
32 changed files with 526 additions and 693 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/alien/arrays/arrays.factor
View File

@ -24,8 +24,6 @@ M: array c-type-align-first first c-type-align-first ;
M: array base-type drop void* base-type ; M: array base-type drop void* base-type ;
M: array stack-size drop void* stack-size ;
PREDICATE: string-type < pair PREDICATE: string-type < pair
first2 [ c-string = ] [ word? ] bi* and ; first2 [ c-string = ] [ word? ] bi* and ;
@ -43,8 +41,6 @@ M: string-type c-type-align-first drop void* c-type-align-first ;
M: string-type base-type drop void* base-type ; M: string-type base-type drop void* base-type ;
M: string-type stack-size drop void* stack-size ;
M: string-type c-type-rep drop int-rep ; M: string-type c-type-rep drop int-rep ;
M: string-type c-type-boxer-quot M: string-type c-type-boxer-quot

5
basis/alien/c-types/c-types-docs.factor
View File

@ -14,11 +14,6 @@ HELP: heap-size
} }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: stack-size
{ $values { "name" "a C type name" } { "size" math:integer } }
{ $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
HELP: <c-type> HELP: <c-type>
{ $values { "c-type" c-type } } { $values { "c-type" c-type } }
{ $description "Creates a prototypical C type. User code should use higher-level facilities to define C types; see " { $link "c-data" } "." } ; { $description "Creates a prototypical C type. User code should use higher-level facilities to define C types; see " { $link "c-data" } "." } ;

13
basis/alien/c-types/c-types.factor
View File

@ -17,8 +17,7 @@ SYMBOLS:
long ulong long ulong
longlong ulonglong longlong ulonglong
float double float double
void* bool void* bool ;
(stack-value) ;
SINGLETON: void SINGLETON: void
@ -114,10 +113,6 @@ GENERIC: heap-size ( name -- size )
M: abstract-c-type heap-size size>> ; M: abstract-c-type heap-size size>> ;
GENERIC: stack-size ( name -- size )
M: c-type stack-size size>> cell align ;
MIXIN: value-type MIXIN: value-type
: c-getter ( name -- quot ) : c-getter ( name -- quot )
@ -144,8 +139,7 @@ PROTOCOL: c-type-protocol
c-type-align c-type-align
c-type-align-first c-type-align-first
base-type base-type
heap-size heap-size ;
stack-size ;
CONSULT: c-type-protocol c-type-name CONSULT: c-type-protocol c-type-name
c-type ; c-type ;
@ -448,9 +442,6 @@ M: pointer c-type
object >>boxed-class object >>boxed-class
\ bool define-primitive-type \ bool define-primitive-type
\ void* c-type clone stack-params >>rep
\ (stack-value) define-primitive-type
] with-compilation-unit ] with-compilation-unit
M: char-16-rep rep-component-type drop char ; M: char-16-rep rep-component-type drop char ;

8
basis/classes/struct/struct.factor
View File

@ -168,14 +168,6 @@ M: struct-c-type c-type ;
M: struct-c-type base-type ; M: struct-c-type base-type ;
M: struct-c-type stack-size
dup value-struct? [ heap-size cell align ] [ drop cell ] if ;
HOOK: flatten-struct-type cpu ( type -- pairs )
M: object flatten-struct-type
stack-size cell /i { int-rep f } <repetition> ;
: large-struct? ( type -- ? ) : large-struct? ( type -- ? )
{ {
{ [ dup void? ] [ drop f ] } { [ dup void? ] [ drop f ] }

14
basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008, 2010 Slava Pestov. ! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences USING: namespaces accessors math math.order assocs kernel sequences
combinators classes words cpu.architecture layouts compiler.cfg combinators classes words cpu.architecture layouts compiler.cfg
compiler.cfg.rpo compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.stack-frame ; compiler.cfg.registers compiler.cfg.stack-frame ;
@ -17,13 +17,15 @@ GENERIC: compute-stack-frame* ( insn -- )
M: ##stack-frame compute-stack-frame* M: ##stack-frame compute-stack-frame*
stack-frame>> request-stack-frame ; stack-frame>> request-stack-frame ;
M: ##call compute-stack-frame* drop frame-required? on ;
M: ##call-gc compute-stack-frame* M: ##call-gc compute-stack-frame*
drop drop
frame-required? on frame-required? on
stack-frame new t >>calls-vm? request-stack-frame ; stack-frame new t >>calls-vm? request-stack-frame ;
M: ##call compute-stack-frame* drop frame-required? on ;
M: ##alien-callback compute-stack-frame* drop frame-required? on ;
M: insn compute-stack-frame* M: insn compute-stack-frame*
class "frame-required?" word-prop class "frame-required?" word-prop
[ frame-required? on ] when ; [ frame-required? on ] when ;
@ -31,10 +33,10 @@ M: insn compute-stack-frame*
: initial-stack-frame ( -- stack-frame ) : initial-stack-frame ( -- stack-frame )
stack-frame new cfg get spill-area-size>> >>spill-area-size ; stack-frame new cfg get spill-area-size>> >>spill-area-size ;
: compute-stack-frame ( insns -- ) : compute-stack-frame ( cfg -- )
frame-required? off
initial-stack-frame stack-frame set initial-stack-frame stack-frame set
[ instructions>> [ compute-stack-frame* ] each ] each-basic-block [ spill-area-size>> 0 > frame-required? set ]
[ [ instructions>> [ compute-stack-frame* ] each ] each-basic-block ] bi
stack-frame get dup stack-frame-size >>total-size drop ; stack-frame get dup stack-frame-size >>total-size drop ;
: build-stack-frame ( cfg -- cfg ) : build-stack-frame ( cfg -- cfg )

268
basis/compiler/cfg/builder/alien/alien.factor
View File

@ -1,100 +1,54 @@
! Copyright (C) 2008, 2010 Slava Pestov. ! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays layouts math math.order math.parser USING: accessors arrays layouts math math.order math.parser
combinators combinators.short-circuit fry make sequences locals combinators combinators.short-circuit fry make sequences
alien alien.private alien.strings alien.c-types alien.libraries sequences.generalizations alien alien.private alien.strings
classes.struct namespaces kernel strings libc quotations words alien.c-types alien.libraries classes.struct namespaces kernel
cpu.architecture compiler.utilities compiler.tree compiler.cfg strings libc locals quotations words cpu.architecture
compiler.utilities compiler.tree compiler.cfg
compiler.cfg.builder compiler.cfg.builder.alien.params compiler.cfg.builder compiler.cfg.builder.alien.params
compiler.cfg.builder.blocks compiler.cfg.instructions compiler.cfg.builder.alien.boxing compiler.cfg.builder.blocks
compiler.cfg.stack-frame compiler.cfg.stacks compiler.cfg.instructions compiler.cfg.stack-frame
compiler.cfg.registers compiler.cfg.hats ; compiler.cfg.stacks compiler.cfg.registers compiler.cfg.hats ;
FROM: compiler.errors => no-such-symbol no-such-library ; FROM: compiler.errors => no-such-symbol no-such-library ;
IN: compiler.cfg.builder.alien IN: compiler.cfg.builder.alien
! output is triples with shape { vreg rep on-stack? } : unbox-parameters ( parameters -- vregs reps )
GENERIC: unbox ( src c-type -- vregs )
M: c-type unbox
[ [ unboxer>> ] [ rep>> ] bi ^^unbox ] [ rep>> ] bi
f 3array 1array ;
M: long-long-type unbox
unboxer>> int-rep ^^unbox
0 cell
[
int-rep f ^^load-memory-imm
int-rep long-long-on-stack? 3array
] bi-curry@ bi 2array ;
GENERIC: unbox-parameter ( src c-type -- vregs )
M: c-type unbox-parameter unbox ;
M: long-long-type unbox-parameter unbox ;
M:: struct-c-type unbox-parameter ( src c-type -- )
src ^^unbox-any-c-ptr :> src
c-type value-struct? [
c-type flatten-struct-type
[| pair i |
src i cells pair first f ^^load-memory-imm
pair first2 3array
] map-index
] [ { { src int-rep f } } ] if ;
: unbox-parameters ( parameters -- vregs )
[ [
[ length iota <reversed> ] keep [ length iota <reversed> ] keep
[ [ [ <ds-loc> ^^peek ] [ base-type ] bi* unbox-parameter ]
[ <ds-loc> ^^peek ] [ base-type ] bi* 2 2 mnmap [ concat ] bi@
unbox-parameter
] 2map concat
] ]
[ length neg ##inc-d ] bi ; [ length neg ##inc-d ] bi ;
: prepare-struct-area ( vregs return -- vregs ) : prepare-struct-caller ( vregs reps return -- vregs' reps' )
#! 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.
large-struct? [ large-struct? [
^^prepare-struct-area int-rep struct-return-on-stack? [ ^^prepare-struct-caller prefix ]
3array prefix [ int-rep struct-return-on-stack? 2array prefix ] bi*
] when ; ] when ;
: (objects>registers) ( vregs -- ) : caller-parameter ( vreg rep on-stack? -- insn )
[ dup reg-class-of reg-class-full? ] dip or
[ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ]
[ [ next-reg-param ] keep \ ##store-reg-param new-insn ]
if ;
: (caller-parameters) ( vregs reps -- )
! Place ##store-stack-param instructions first. This ensures ! Place ##store-stack-param instructions first. This ensures
! that no registers are used after the ##store-reg-param ! that no registers are used after the ##store-reg-param
! instructions. ! instructions.
[ [ first2 caller-parameter ] 2map
first3 [ dup reg-class-of reg-class-full? ] dip or [ ##store-stack-param? ] partition [ % ] bi@ ;
[ [ 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 ) : caller-parameters ( params -- stack-size )
[ abi>> ] [ parameters>> ] [ return>> ] tri [ abi>> ] [ parameters>> ] [ return>> ] tri
'[ '[
_ unbox-parameters _ unbox-parameters
_ prepare-struct-area _ prepare-struct-caller
(objects>registers) (caller-parameters)
stack-params get stack-params get
] with-param-regs ; ] with-param-regs ;
GENERIC: box-return ( c-type -- dst )
M: c-type box-return
[ f ] dip [ rep>> ] [ boxer>> ] bi ^^box ;
M: long-long-type box-return
[ f ] dip boxer>> ^^box-long-long ;
M: struct-c-type box-return
dup return-struct-in-registers?
[ ^^box-small-struct ] [ [ f ] dip ^^box-large-struct ] if ;
: box-return* ( node -- ) : box-return* ( node -- )
return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ; return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;
@ -126,13 +80,8 @@ M: array dlsym-valid? '[ _ dlsym ] any? ;
bi 2dup check-dlsym ; bi 2dup check-dlsym ;
: return-size ( c-type -- n ) : return-size ( c-type -- n )
#! Amount of space we reserve for a return value. ! Amount of space we reserve for a return value.
{ dup large-struct? [ heap-size ] [ drop 0 ] if ;
{ [ dup void? ] [ drop 0 ] }
{ [ dup base-type struct-c-type? not ] [ drop 0 ] }
{ [ dup large-struct? not ] [ drop 2 cells ] }
[ heap-size ]
} cond ;
: alien-node-height ( params -- ) : alien-node-height ( params -- )
[ out-d>> length ] [ in-d>> length ] bi - adjust-d ; [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
@ -158,7 +107,7 @@ M: array dlsym-valid? '[ _ dlsym ] any? ;
M: #alien-invoke emit-node M: #alien-invoke emit-node
[ [
{ {
[ objects>registers ] [ caller-parameters ]
[ alien-invoke-dlsym ##alien-invoke ] [ alien-invoke-dlsym ##alien-invoke ]
[ emit-stack-frame ] [ emit-stack-frame ]
[ box-return* ] [ box-return* ]
@ -169,7 +118,7 @@ M:: #alien-indirect emit-node ( node -- )
node [ node [
D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src
{ {
[ objects>registers ] [ caller-parameters ]
[ drop src ##alien-indirect ] [ drop src ##alien-indirect ]
[ emit-stack-frame ] [ emit-stack-frame ]
[ box-return* ] [ box-return* ]
@ -179,132 +128,52 @@ M:: #alien-indirect emit-node ( node -- )
M: #alien-assembly emit-node M: #alien-assembly emit-node
[ [
{ {
[ objects>registers ] [ caller-parameters ]
[ quot>> ##alien-assembly ] [ quot>> ##alien-assembly ]
[ emit-stack-frame ] [ emit-stack-frame ]
[ box-return* ] [ box-return* ]
} cleave } cleave
] emit-alien-block ; ] emit-alien-block ;
GENERIC: box-parameter ( n c-type -- dst ) : callee-parameter ( rep on-stack? -- dst insn )
[ next-vreg dup ] 2dip
[ dup reg-class-of reg-class-full? ] dip or
[ [ alloc-stack-param ] keep \ ##load-stack-param new-insn ]
[ [ next-reg-param ] keep \ ##load-reg-param new-insn ]
if ;
M: c-type box-parameter : prepare-struct-callee ( c-type -- vreg )
[ rep>> ] [ boxer>> ] bi ^^box ; large-struct?
[ int-rep struct-return-on-stack? callee-parameter , ] [ f ] if ;
M: long-long-type box-parameter : (callee-parameters) ( params -- vregs reps )
boxer>> ^^box-long-long ; [ flatten-parameter-type ] map
: 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 ]
[ [
prepare-parameters [ [ first2 callee-parameter ] 1 2 mnmap ] 1 2 mnmap
[ concat [ ##load-reg-param? ] partition [ % ] bi@
next-vreg next-vreg ##save-context ] keep ;
base-type box-parameter swap <ds-loc> ##replace
] 3each
] bi ;
:: alloc-parameter ( rep -- reg rep ) : box-parameters ( vregs reps params -- )
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 abi>> [
dup (registers>objects)
##begin-callback ##begin-callback
next-vreg next-vreg ##restore-context next-vreg next-vreg ##restore-context
box-parameters [
] with-param-regs ; next-vreg next-vreg ##save-context
box-parameter
1 ##inc-d D 0 ##replace
] 3each ;
: callback-return-quot ( ctype -- quot ) : callee-parameters ( params -- stack-size )
return>> { [ abi>> ] [ return>> ] [ parameters>> ] tri
{ [ dup void? ] [ drop [ ] ] } '[
{ [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] } _ prepare-struct-callee struct-return-area set
[ c-type c-type-unboxer-quot ] _ [ base-type ] map [ (callee-parameters) ] [ box-parameters ] bi
} cond ;
: callback-prep-quot ( params -- quot )
parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
: wrap-callback-quot ( params -- quot )
[ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append
yield-hook get
'[ _ _ do-callback ]
>quotation ;
GENERIC: unbox-return ( src c-type -- )
M: c-type unbox-return
unbox first first2 ##store-return ;
M: long-long-type unbox-return
unbox first2 [ first ] bi@ ##store-long-long-return ;
M: struct-c-type unbox-return
[ ^^unbox-any-c-ptr ] dip ##store-struct-return ;
: emit-callback-stack-frame ( params -- )
[ alien-parameters [ stack-size ] map-sum ] [ return>> ] bi
<alien-stack-frame> ##stack-frame ;
: stack-args-size ( params -- n )
dup abi>> [
alien-parameters flatten-c-types
[ alloc-parameter 2drop ] each
stack-params get stack-params get
] with-param-regs ; struct-return-area get
] with-param-regs
struct-return-area set ;
: callback-stack-cleanup ( params -- ) : callback-stack-cleanup ( stack-size params -- )
[ xt>> ] [ [ stack-args-size ] [ return>> ] [ abi>> ] tri stack-cleanup ] bi [ nip xt>> ] [ [ return>> ] [ abi>> ] bi stack-cleanup ] 2bi
"stack-cleanup" set-word-prop ; "stack-cleanup" set-word-prop ;
M: #alien-callback emit-node M: #alien-callback emit-node
@ -313,21 +182,16 @@ M: #alien-callback emit-node
##prologue ##prologue
[ [
{ {
[ registers>objects ] [ callee-parameters ]
[ emit-callback-stack-frame ] [ quot>> ##alien-callback ]
[ callback-stack-cleanup ]
[ wrap-callback-quot ##alien-callback ]
[
return>> {
{ [ dup void? ] [ drop ##end-callback ] }
{ [ dup large-struct? ] [ drop ##end-callback ] }
[ [
return>> [ ##end-callback ] [
[ D 0 ^^peek ] dip [ D 0 ^^peek ] dip
##end-callback ##end-callback
base-type unbox-return base-type unbox-return
] if-void
] ]
} cond [ callback-stack-cleanup ]
]
} cleave } cleave
] emit-alien-block ] emit-alien-block
##epilogue ##epilogue

1
basis/compiler/cfg/builder/alien/boxing/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

137
basis/compiler/cfg/builder/alien/boxing/boxing.factor Normal file
View File

@ -0,0 +1,137 @@
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types arrays assocs classes.struct fry
kernel layouts locals math namespaces sequences
sequences.generalizations system
compiler.cfg.builder.alien.params compiler.cfg.hats
compiler.cfg.instructions cpu.architecture ;
IN: compiler.cfg.builder.alien.boxing
SYMBOL: struct-return-area
! pairs have shape { rep on-stack? }
GENERIC: flatten-c-type ( c-type -- pairs )
M: c-type flatten-c-type
rep>> f 2array 1array ;
M: long-long-type flatten-c-type
drop 2 [ int-rep long-long-on-stack? 2array ] replicate ;
HOOK: flatten-struct-type cpu ( type -- pairs )
M: object flatten-struct-type
heap-size cell align cell /i { int-rep f } <repetition> ;
M: struct-c-type flatten-c-type
flatten-struct-type ;
: stack-size ( c-type -- n )
base-type flatten-c-type keys 0 [ rep-size + ] reduce ;
: component-offsets ( reps -- offsets )
0 [ rep-size + ] accumulate nip ;
:: explode-struct ( src c-type -- vregs reps )
c-type flatten-struct-type :> reps
reps keys dup component-offsets
[| rep offset | src offset rep f ^^load-memory-imm ] 2map
reps ;
:: implode-struct ( src vregs reps -- )
vregs reps dup component-offsets
[| vreg rep offset | vreg src offset rep f ##store-memory-imm ] 3each ;
GENERIC: unbox ( src c-type -- vregs reps )
M: c-type unbox
[ unboxer>> ] [ rep>> ] bi
[ ^^unbox 1array ] [ nip f 2array 1array ] 2bi ;
M: long-long-type unbox
unboxer>> int-rep ^^unbox
0 cell [ int-rep f ^^load-memory-imm ] bi-curry@ bi 2array
int-rep long-long-on-stack? 2array dup 2array ;
M: struct-c-type unbox ( src c-type -- vregs )
[ ^^unbox-any-c-ptr ] dip explode-struct ;
: frob-struct ( c-type -- c-type )
dup value-struct? [ drop void* base-type ] unless ;
GENERIC: unbox-parameter ( src c-type -- vregs reps )
M: c-type unbox-parameter unbox ;
M: long-long-type unbox-parameter unbox ;
M: struct-c-type unbox-parameter frob-struct unbox ;
GENERIC: unbox-return ( src c-type -- )
: store-return ( vregs reps -- )
[
[ [ next-return-reg ] keep ##store-reg-param ] 2each
] with-return-regs ;
: (unbox-return) ( src c-type -- vregs reps )
! Don't care about on-stack? flag when looking at return
! values.
unbox keys ;
M: c-type unbox-return (unbox-return) store-return ;
M: long-long-type unbox-return (unbox-return) store-return ;
M: struct-c-type unbox-return
dup return-struct-in-registers?
[ unbox keys store-return ]
[ [ struct-return-area get ] 2dip (unbox-return) implode-struct ] if ;
GENERIC: flatten-parameter-type ( c-type -- reps )
M: c-type flatten-parameter-type flatten-c-type ;
M: long-long-type flatten-parameter-type flatten-c-type ;
M: struct-c-type flatten-parameter-type frob-struct flatten-c-type ;
GENERIC: box ( vregs reps c-type -- dst )
M: c-type box
[ first ] [ drop ] [ [ boxer>> ] [ rep>> ] bi ] tri* ^^box ;
M: long-long-type box
[ first2 ] [ drop ] [ boxer>> ] tri* ^^box-long-long ;
M: struct-c-type box
'[ _ heap-size ^^allot-byte-array dup ^^unbox-byte-array ] 2dip
implode-struct ;
GENERIC: box-parameter ( vregs reps c-type -- dst )
M: c-type box-parameter box ;
M: long-long-type box-parameter box ;
M: struct-c-type box-parameter frob-struct box ;
GENERIC: box-return ( c-type -- dst )
: load-return ( c-type -- vregs reps )
[
flatten-c-type keys
[ [ [ next-return-reg ] keep ^^load-reg-param ] keep ]
1 2 mnmap
] with-return-regs ;
M: c-type box-return [ load-return ] keep box ;
M: long-long-type box-return [ load-return ] keep box ;
M: struct-c-type box-return
[
dup return-struct-in-registers?
[ load-return ]
[ [ ^^prepare-struct-caller ] dip explode-struct keys ] if
] keep box ;

36
basis/compiler/cfg/builder/alien/params/params.factor
View File

@ -1,9 +1,11 @@
! Copyright (C) 2010 Slava Pestov. ! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: cpu.architecture fry kernel layouts math math.order USING: cpu.architecture fry kernel layouts math math.order
namespaces sequences vectors ; namespaces sequences vectors assocs ;
IN: compiler.cfg.builder.alien.params IN: compiler.cfg.builder.alien.params
SYMBOL: stack-params
: alloc-stack-param ( rep -- n ) : alloc-stack-param ( rep -- n )
stack-params get stack-params get
[ rep-size cell align stack-params +@ ] dip ; [ rep-size cell align stack-params +@ ] dip ;
@ -23,27 +25,29 @@ IN: compiler.cfg.builder.alien.params
GENERIC: next-reg-param ( rep -- reg ) GENERIC: next-reg-param ( rep -- reg )
M: int-rep next-reg-param M: int-rep next-reg-param
[ ?dummy-stack-params ] [ ?dummy-fp-params ] bi int-regs get pop ; [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi
int-regs get pop ;
M: float-rep next-reg-param M: float-rep next-reg-param
[ ?dummy-stack-params ] [ ?dummy-int-params ] bi float-regs get pop ; [ ?dummy-stack-params ] [ ?dummy-int-params ] bi
float-regs get pop ;
M: double-rep next-reg-param M: double-rep next-reg-param
[ ?dummy-stack-params ] [ ?dummy-int-params ] bi float-regs get pop ; [ ?dummy-stack-params ] [ ?dummy-int-params ] bi
float-regs get pop ;
GENERIC: reg-class-full? ( reg-class -- ? ) : reg-class-full? ( reg-class -- ? ) get empty? ;
M: stack-params reg-class-full? drop t ;
M: reg-class reg-class-full? get empty? ;
: init-reg-class ( abi reg-class -- ) : init-reg-class ( abi reg-class -- )
[ swap param-regs <reversed> >vector ] keep set ; [ swap param-regs at <reversed> >vector ] keep set ;
: init-regs ( regs -- )
[ <reversed> >vector swap set ] assoc-each ;
: with-param-regs ( abi quot -- ) : with-param-regs ( abi quot -- )
'[ '[ param-regs init-regs 0 stack-params set @ ] with-scope ; inline
[ int-regs init-reg-class ]
[ float-regs init-reg-class ] bi : next-return-reg ( rep -- reg ) reg-class-of get pop ;
0 stack-params set
@ : with-return-regs ( quot -- )
] with-scope ; inline '[ return-regs init-regs @ ] with-scope ; inline

66
basis/compiler/cfg/instructions/instructions.factor
View File

@ -641,35 +641,30 @@ INSN: ##store-stack-param
use: src use: src
literal: n rep ; literal: n rep ;
INSN: ##store-return INSN: ##load-reg-param
use: src def: dst
literal: rep ; literal: reg rep ;
INSN: ##store-struct-return INSN: ##load-stack-param
use: src/int-rep def: dst
literal: c-type ; literal: n rep ;
INSN: ##store-long-long-return INSN: ##prepare-struct-caller
use: src1/int-rep src2/int-rep ;
INSN: ##prepare-struct-area
def: dst/int-rep ; def: dst/int-rep ;
INSN: ##box INSN: ##box
def: dst/tagged-rep def: dst/tagged-rep
literal: n rep boxer ; use: src
literal: boxer rep ;
INSN: ##box-long-long INSN: ##box-long-long
def: dst/tagged-rep def: dst/tagged-rep
literal: n boxer ; use: src1/int-rep src2/int-rep
literal: boxer ;
INSN: ##box-small-struct INSN: ##allot-byte-array
def: dst/tagged-rep def: dst/tagged-rep
literal: c-type ; literal: size ;
INSN: ##box-large-struct
def: dst/tagged-rep
literal: n c-type ;
INSN: ##alien-invoke INSN: ##alien-invoke
literal: symbols dll ; literal: symbols dll ;
@ -683,9 +678,6 @@ use: src/int-rep ;
INSN: ##alien-assembly INSN: ##alien-assembly
literal: quot ; literal: quot ;
INSN: ##save-param-reg
literal: offset reg rep ;
INSN: ##begin-callback ; INSN: ##begin-callback ;
INSN: ##alien-callback INSN: ##alien-callback
@ -849,27 +841,31 @@ UNION: conditional-branch-insn
UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ; UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ; UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
! Instructions that clobber registers ! Instructions that clobber registers. They receive inputs and
UNION: clobber-insn ! produce outputs in spill slots.
##call-gc UNION: hairy-clobber-insn
##unary-float-function ##load-reg-param
##binary-float-function
##box
##box-long-long
##box-small-struct
##box-large-struct
##unbox
##store-reg-param ##store-reg-param
##store-return ##call-gc
##store-struct-return
##store-long-long-return
##alien-invoke ##alien-invoke
##alien-indirect ##alien-indirect
##alien-assembly ##alien-assembly
##save-param-reg
##begin-callback ##begin-callback
##end-callback ; ##end-callback ;
! Instructions that clobber registers but are allowed to produce
! outputs in registers. Inputs are in spill slots, except for
! inputs coalesced with the output, in which case that input
! will be in a register.
UNION: clobber-insn
hairy-clobber-insn
##unary-float-function
##binary-float-function
##unbox
##box
##box-long-long
##allot-byte-array ;
! Instructions that have complex expansions and require that the ! Instructions that have complex expansions and require that the
! output registers are not equal to any of the input registers ! output registers are not equal to any of the input registers
UNION: def-is-use-insn UNION: def-is-use-insn

38
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -36,31 +36,39 @@ IN: compiler.cfg.linear-scan.allocation
[ drop assign-blocked-register ] [ drop assign-blocked-register ]
} cond ; } cond ;
: spill-at-sync-point ( n live-interval -- ? ) : spill-at-sync-point? ( sync-point live-interval -- ? )
! If the live interval has a definition at 'n', don't spill ! If the live interval has a definition at a keep-dst?
2dup find-use ! sync-point, don't spill.
{ [ ] [ def-rep>> ] } 1&& {
[ 2drop t ] [ swap spill f ] if ; [ drop keep-dst?>> not ]
[ [ n>> ] dip find-use dup [ def-rep>> ] when not ]
} 2|| ;
: handle-sync-point ( n -- ) : spill-at-sync-point ( sync-point live-interval -- ? )
2dup spill-at-sync-point?
[ swap n>> spill f ] [ 2drop t ] if ;
GENERIC: handle-progress* ( obj -- )
M: live-interval handle-progress* drop ;
M: sync-point handle-progress*
active-intervals get values active-intervals get values
[ [ spill-at-sync-point ] with filter! drop ] with each ; [ [ spill-at-sync-point ] with filter! drop ] with each ;
:: handle-progress ( n sync? -- ) :: handle-progress ( n obj -- )
n { n progress set
[ progress set ] n deactivate-intervals
[ deactivate-intervals ] obj handle-progress*
[ sync? [ handle-sync-point ] [ drop ] if ] n activate-intervals ;
[ activate-intervals ]
} cleave ;
GENERIC: handle ( obj -- ) GENERIC: handle ( obj -- )
M: live-interval handle ( live-interval -- ) M: live-interval handle ( live-interval -- )
[ start>> f handle-progress ] [ assign-register ] bi ; [ [ start>> ] keep handle-progress ] [ assign-register ] bi ;
M: sync-point handle ( sync-point -- ) M: sync-point handle ( sync-point -- )
n>> t handle-progress ; [ n>> ] keep handle-progress ;
: smallest-heap ( heap1 heap2 -- heap ) : smallest-heap ( heap1 heap2 -- heap )
! If heap1 and heap2 have the same key, favors heap1. ! If heap1 and heap2 have the same key, favors heap1.

7
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

@ -134,7 +134,7 @@ M: vreg-insn compute-live-intervals* ( insn -- )
] if ; ] if ;
! A location where all registers have to be spilled ! A location where all registers have to be spilled
TUPLE: sync-point n ; TUPLE: sync-point n keep-dst? ;
C: <sync-point> sync-point C: <sync-point> sync-point
@ -143,8 +143,11 @@ SYMBOL: sync-points
GENERIC: compute-sync-points* ( insn -- ) GENERIC: compute-sync-points* ( insn -- )
M: hairy-clobber-insn compute-sync-points*
insn#>> f <sync-point> sync-points get push ;
M: clobber-insn compute-sync-points* M: clobber-insn compute-sync-points*
insn#>> <sync-point> sync-points get push ; insn#>> t <sync-point> sync-points get push ;
M: insn compute-sync-points* drop ; M: insn compute-sync-points* drop ;

12
basis/compiler/cfg/stack-frame/stack-frame.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009, 2010 Slava Pestov. ! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: math math.order namespaces accessors kernel layouts USING: math math.order namespaces accessors kernel layouts
combinators combinators.smart assocs sequences cpu.architecture combinators assocs sequences cpu.architecture
words compiler.cfg.instructions ; words compiler.cfg.instructions ;
IN: compiler.cfg.stack-frame IN: compiler.cfg.stack-frame
@ -13,16 +13,14 @@ TUPLE: stack-frame
{ calls-vm? boolean } ; { calls-vm? boolean } ;
! Stack frame utilities ! Stack frame utilities
: param-base ( -- n ) : return-offset ( -- offset )
stack-frame get [ params>> ] [ return>> ] bi + ; stack-frame get params>> ;
: spill-offset ( n -- offset ) : spill-offset ( n -- offset )
param-base + ; stack-frame get [ params>> ] [ return>> ] bi + + ;
: (stack-frame-size) ( stack-frame -- n ) : (stack-frame-size) ( stack-frame -- n )
[ [ params>> ] [ return>> ] [ spill-area-size>> ] tri + + ;
[ params>> ] [ return>> ] [ spill-area-size>> ] tri
] sum-outputs ;
: max-stack-frame ( frame1 frame2 -- frame3 ) : max-stack-frame ( frame1 frame2 -- frame3 )
[ stack-frame new ] 2dip [ stack-frame new ] 2dip

11
basis/compiler/codegen/codegen.factor
View File

@ -287,15 +287,12 @@ CONDITIONAL: ##fixnum-mul %fixnum-mul
CODEGEN: ##unbox %unbox CODEGEN: ##unbox %unbox
CODEGEN: ##store-reg-param %store-reg-param CODEGEN: ##store-reg-param %store-reg-param
CODEGEN: ##store-stack-param %store-stack-param CODEGEN: ##store-stack-param %store-stack-param
CODEGEN: ##store-return %store-return CODEGEN: ##load-reg-param %load-reg-param
CODEGEN: ##store-struct-return %store-struct-return CODEGEN: ##load-stack-param %load-stack-param
CODEGEN: ##store-long-long-return %store-long-long-return CODEGEN: ##prepare-struct-caller %prepare-struct-caller
CODEGEN: ##prepare-struct-area %prepare-struct-area
CODEGEN: ##box %box CODEGEN: ##box %box
CODEGEN: ##box-long-long %box-long-long CODEGEN: ##box-long-long %box-long-long
CODEGEN: ##box-large-struct %box-large-struct CODEGEN: ##allot-byte-array %allot-byte-array
CODEGEN: ##box-small-struct %box-small-struct
CODEGEN: ##save-param-reg %save-param-reg
CODEGEN: ##alien-invoke %alien-invoke CODEGEN: ##alien-invoke %alien-invoke
CODEGEN: ##cleanup %cleanup CODEGEN: ##cleanup %cleanup
CODEGEN: ##alien-indirect %alien-indirect CODEGEN: ##alien-indirect %alien-indirect

51
basis/cpu/architecture/architecture.factor
View File

@ -150,9 +150,6 @@ SINGLETONS: int-regs float-regs ;
UNION: reg-class int-regs float-regs ; UNION: reg-class int-regs float-regs ;
CONSTANT: reg-classes { int-regs float-regs } CONSTANT: reg-classes { int-regs float-regs }
! A pseudo-register class for parameters spilled on the stack
SINGLETON: stack-params
! On x86, vectors and floats are stored in the same register bank ! On x86, vectors and floats are stored in the same register bank
! On PowerPC they are distinct ! On PowerPC they are distinct
HOOK: vector-regs cpu ( -- reg-class ) HOOK: vector-regs cpu ( -- reg-class )
@ -165,7 +162,6 @@ M: float-rep reg-class-of drop float-regs ;
M: double-rep reg-class-of drop float-regs ; M: double-rep reg-class-of drop float-regs ;
M: vector-rep reg-class-of drop vector-regs ; M: vector-rep reg-class-of drop vector-regs ;
M: scalar-rep reg-class-of drop vector-regs ; M: scalar-rep reg-class-of drop vector-regs ;
M: stack-params reg-class-of drop stack-params ;
GENERIC: rep-size ( rep -- n ) foldable GENERIC: rep-size ( rep -- n ) foldable
@ -173,7 +169,6 @@ M: tagged-rep rep-size drop cell ;
M: int-rep rep-size drop cell ; M: int-rep rep-size drop cell ;
M: float-rep rep-size drop 4 ; M: float-rep rep-size drop 4 ;
M: double-rep rep-size drop 8 ; M: double-rep rep-size drop 8 ;
M: stack-params rep-size drop cell ;
M: vector-rep rep-size drop 16 ; M: vector-rep rep-size drop 16 ;
M: char-scalar-rep rep-size drop 1 ; M: char-scalar-rep rep-size drop 1 ;
M: uchar-scalar-rep rep-size drop 1 ; M: uchar-scalar-rep rep-size drop 1 ;
@ -507,22 +502,6 @@ HOOK: %reload cpu ( dst rep src -- )
HOOK: %loop-entry cpu ( -- ) HOOK: %loop-entry cpu ( -- )
! FFI stuff
! Return values of this class go here
GENERIC: return-reg ( reg-class -- reg )
! Sequence of registers used for parameter passing in class
GENERIC# param-regs 1 ( reg-class abi -- regs )
M: stack-params param-regs 2drop f ;
GENERIC# param-reg 1 ( n reg-class abi -- reg )
M: reg-class param-reg param-regs nth ;
M: stack-params param-reg 2drop ;
! Does this architecture support %load-float, %load-double, ! Does this architecture support %load-float, %load-double,
! and %load-vector? ! and %load-vector?
HOOK: fused-unboxing? cpu ( -- ? ) HOOK: fused-unboxing? cpu ( -- ? )
@ -552,6 +531,14 @@ M: object immediate-comparand? ( n -- ? )
: immediate-shift-count? ( n -- ? ) : immediate-shift-count? ( n -- ? )
0 cell-bits 1 - between? ; 0 cell-bits 1 - between? ;
! FFI stuff
! Return values of this class go here
HOOK: return-regs cpu ( -- regs )
! Registers used for parameter passing
HOOK: param-regs cpu ( abi -- regs )
! Is this structure small enough to be returned in registers? ! Is this structure small enough to be returned in registers?
HOOK: return-struct-in-registers? cpu ( c-type -- ? ) HOOK: return-struct-in-registers? cpu ( c-type -- ? )
@ -584,26 +571,16 @@ HOOK: %store-reg-param cpu ( src reg rep -- )
HOOK: %store-stack-param cpu ( src n rep -- ) HOOK: %store-stack-param cpu ( src n rep -- )
HOOK: %store-return cpu ( src rep -- ) HOOK: %prepare-struct-caller cpu ( dst -- )
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, ! Call a function to convert a value into a tagged pointer,
! possibly allocating a bignum, float, or alien instance, ! possibly allocating a bignum, float, or alien instance,
! which is then pushed on the data stack ! which is then pushed on the data stack
HOOK: %box cpu ( dst n rep func -- ) HOOK: %box cpu ( dst src func rep -- )
HOOK: %box-long-long cpu ( dst n func -- ) HOOK: %box-long-long cpu ( dst src1 src2 func -- )
HOOK: %box-small-struct cpu ( dst c-type -- ) HOOK: %allot-byte-array cpu ( dst size -- )
HOOK: %box-large-struct cpu ( dst n c-type -- )
HOOK: %save-param-reg cpu ( stack reg rep -- )
HOOK: %restore-context cpu ( temp1 temp2 -- ) HOOK: %restore-context cpu ( temp1 temp2 -- )
@ -617,6 +594,10 @@ M: object %cleanup ( n -- ) drop ;
HOOK: %alien-indirect cpu ( src -- ) HOOK: %alien-indirect cpu ( src -- )
HOOK: %load-reg-param cpu ( dst reg rep -- )
HOOK: %load-stack-param cpu ( dst n rep -- )
HOOK: %begin-callback cpu ( -- ) HOOK: %begin-callback cpu ( -- )
HOOK: %alien-callback cpu ( quot -- ) HOOK: %alien-callback cpu ( quot -- )

6
basis/cpu/ppc/linux/linux.factor
View File

@ -13,7 +13,11 @@ M: linux reserved-area-size 2 cells ;
M: linux lr-save 1 cells ; M: linux lr-save 1 cells ;
M: float-regs param-regs 2drop { 1 2 3 4 5 6 7 8 } ; M: ppc param-regs
drop {
{ int-regs { 3 4 5 6 7 8 9 10 } }
{ float-regs { 1 2 3 4 5 6 7 8 } }
} ;
M: ppc value-struct? drop f ; M: ppc value-struct? drop f ;

6
basis/cpu/ppc/macosx/macosx.factor
View File

@ -8,7 +8,11 @@ M: macosx reserved-area-size 6 cells ;
M: macosx lr-save 2 cells ; M: macosx lr-save 2 cells ;
M: float-regs param-regs 2drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ; M: ppc param-regs
drop {
{ int-regs { 3 4 5 6 7 8 9 10 } }
{ float-regs { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
} ;
M: ppc value-struct? drop t ; M: ppc value-struct? drop t ;

16
basis/cpu/ppc/ppc.factor
View File

@ -226,10 +226,10 @@ M: spill-slot float-function-param* [ 1 ] dip n>> spill@ LFD ;
M: integer float-function-param* FMR ; M: integer float-function-param* FMR ;
: float-function-param ( i src -- ) : float-function-param ( i src -- )
[ float-regs cdecl param-regs nth ] dip float-function-param* ; [ float-regs cdecl param-regs at nth ] dip float-function-param* ;
: float-function-return ( reg -- ) : float-function-return ( reg -- )
float-regs return-reg double-rep %copy ; float-regs return-regs at first double-rep %copy ;
M:: ppc %unary-float-function ( dst src func -- ) M:: ppc %unary-float-function ( dst src func -- )
0 src float-function-param 0 src float-function-param
@ -665,11 +665,11 @@ M: ppc %reload ( dst rep src -- )
M: ppc %loop-entry ; M: ppc %loop-entry ;
M: int-regs return-reg drop 3 ; M: ppc return-regs
{
M: int-regs param-regs 2drop { 3 4 5 6 7 8 9 10 } ; { int-regs { 3 4 5 6 } }
{ float-regs { 1 } }
M: float-regs return-reg drop 1 ; } ;
M:: ppc %save-param-reg ( stack reg rep -- ) M:: ppc %save-param-reg ( stack reg rep -- )
reg stack local@ rep store-to-frame ; reg stack local@ rep store-to-frame ;
@ -697,7 +697,7 @@ M: spill-slot store-param [ 1 ] dip n>> spill@ STW ;
M:: ppc %unbox ( src n rep func -- ) M:: ppc %unbox ( src n rep func -- )
src func call-unbox-func src func call-unbox-func
! Store the return value on the C stack ! Store the return value on the C stack
n [ rep reg-class-of return-reg rep %save-param-reg ] when* ; n [ rep reg-class-of return-regs at first rep %save-param-reg ] when* ;
M:: ppc %unbox-long-long ( src n func -- ) M:: ppc %unbox-long-long ( src n func -- )
src func call-unbox-func src func call-unbox-func

190
basis/cpu/x86/32/32.factor
View File

@ -2,11 +2,12 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: locals alien alien.c-types alien.libraries alien.syntax USING: locals alien alien.c-types alien.libraries alien.syntax
arrays kernel fry math namespaces sequences system layouts io arrays kernel fry math namespaces sequences system layouts io
vocabs.loader accessors init classes.struct combinators vocabs.loader accessors init classes.struct combinators make
make words compiler.constants compiler.codegen.fixup words compiler.constants compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.instructions compiler.cfg.builder
compiler.cfg.stack-frame cpu.x86.assembler cpu.x86.assembler.operands compiler.cfg.builder.alien.boxing compiler.cfg.intrinsics
cpu.x86 cpu.architecture vm ; compiler.cfg.stack-frame cpu.x86.assembler
cpu.x86.assembler.operands cpu.x86 cpu.architecture vm ;
FROM: layouts => cell ; FROM: layouts => cell ;
IN: cpu.x86.32 IN: cpu.x86.32
@ -20,19 +21,12 @@ M: x86.32 ds-reg ESI ;
M: x86.32 rs-reg EDI ; M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ; M: x86.32 stack-reg ESP ;
M: x86.32 frame-reg EBP ; M: x86.32 frame-reg EBP ;
M: x86.32 temp-reg ECX ;
M: x86.32 immediate-comparand? ( obj -- ? ) drop t ; M: x86.32 immediate-comparand? ( obj -- ? ) drop t ;
M:: x86.32 %load-vector ( dst val rep -- ) M:: x86.32 %load-vector ( dst val rep -- )
dst 0 [] rep copy-memory* val rc-absolute rel-binary-literal ; dst 0 [] rep copy-memory* val rc-absolute rel-binary-literal ;
M: x86.32 %load-float ( dst val -- )
<float> float-rep %load-vector ;
M: x86.32 %load-double ( dst val -- )
<double> double-rep %load-vector ;
M: x86.32 %mov-vm-ptr ( reg -- ) M: x86.32 %mov-vm-ptr ( reg -- )
0 MOV 0 rc-absolute-cell rel-vm ; 0 MOV 0 rc-absolute-cell rel-vm ;
@ -45,9 +39,6 @@ M: x86.32 %set-vm-field ( dst field -- )
M: x86.32 %vm-field-ptr ( dst field -- ) M: x86.32 %vm-field-ptr ( dst field -- )
[ 0 MOV ] dip 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 extra-stack-space calls-vm?>> 16 0 ? ; M: x86.32 extra-stack-space calls-vm?>> 16 0 ? ;
M: x86.32 %mark-card M: x86.32 %mark-card
@ -80,8 +71,6 @@ M: x86.32 pic-tail-reg EDX ;
M: x86.32 reserved-stack-space 0 ; M: x86.32 reserved-stack-space 0 ;
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
: save-vm-ptr ( n -- ) : save-vm-ptr ( n -- )
stack@ 0 MOV 0 rc-absolute-cell rel-vm ; stack@ 0 MOV 0 rc-absolute-cell rel-vm ;
@ -94,56 +83,19 @@ M: x86.32 return-struct-in-registers? ( c-type -- ? )
! On x86, parameters are usually never passed in registers, ! On x86, parameters are usually never passed in registers,
! except with Microsoft's "thiscall" and "fastcall" abis ! except with Microsoft's "thiscall" and "fastcall" abis
M: int-regs return-reg drop EAX ; M: x86.32 param-regs
M: float-regs param-regs 2drop { } ; {
{ thiscall [ { { int-regs { ECX } } { float-regs { } } } ] }
M: int-regs param-regs { fastcall [ { { int-regs { ECX EDX } } { float-regs { } } } ] }
nip { [ drop { { int-regs { } } { float-regs { } } } ]
{ thiscall [ { ECX } ] }
{ fastcall [ { ECX EDX } ] }
[ drop { } ]
} case ; } case ;
GENERIC: load-return-reg ( src rep -- ) ! Need a fake return-reg for floats
GENERIC: store-return-reg ( dst rep -- ) M: x86.32 return-regs
{
M: stack-params load-return-reg drop EAX swap MOV ; { int-regs { EAX EDX } }
M: stack-params store-return-reg drop EAX MOV ; { float-regs { f } }
} ;
M: int-rep load-return-reg drop EAX swap MOV ;
M: int-rep store-return-reg drop EAX MOV ;
:: load-float-return ( src x87-insn sse-insn -- )
src register? [
ESP 4 SUB
ESP [] src sse-insn execute
ESP [] x87-insn execute
ESP 4 ADD
] [
src x87-insn execute
] if ; inline
:: store-float-return ( dst x87-insn sse-insn -- )
dst register? [
ESP 4 SUB
ESP [] x87-insn execute
dst ESP [] sse-insn execute
ESP 4 ADD
] [
dst x87-insn execute
] if ; inline
M: float-rep load-return-reg
drop \ FLDS \ MOVSS load-float-return ;
M: float-rep store-return-reg
drop \ FSTPS \ MOVSS store-float-return ;
M: double-rep load-return-reg
drop \ FLDL \ MOVSD load-float-return ;
M: double-rep store-return-reg
drop \ FSTPL \ MOVSD store-float-return ;
M: x86.32 %prologue ( n -- ) M: x86.32 %prologue ( n -- )
dup PUSH dup PUSH
@ -153,6 +105,40 @@ M: x86.32 %prologue ( n -- )
M: x86.32 %prepare-jump M: x86.32 %prepare-jump
pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ; pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
:: load-float-return ( dst x87-insn sse-insn -- )
dst register? [
ESP 4 SUB
ESP [] x87-insn execute
dst ESP [] sse-insn execute
ESP 4 ADD
] [
dst x87-insn execute
] if ; inline
M: x86.32 %load-reg-param ( dst reg rep -- )
[ ?spill-slot ] dip {
{ int-rep [ MOV ] }
{ float-rep [ drop \ FSTPS \ MOVSS load-float-return ] }
{ double-rep [ drop \ FSTPL \ MOVSD load-float-return ] }
} case ;
:: store-float-return ( src x87-insn sse-insn -- )
src register? [
ESP 4 SUB
ESP [] src sse-insn execute
ESP [] x87-insn execute
ESP 4 ADD
] [
src x87-insn execute
] if ; inline
M: x86.32 %store-reg-param ( src reg rep -- )
[ ?spill-slot ] dip {
{ int-rep [ swap MOV ] }
{ float-rep [ \ FLDS \ MOVSS store-float-return ] }
{ double-rep [ \ FLDL \ MOVSD store-float-return ] }
} case ;
:: call-unbox-func ( src func -- ) :: call-unbox-func ( src func -- )
EAX src tagged-rep %copy EAX src tagged-rep %copy
4 save-vm-ptr 4 save-vm-ptr
@ -161,77 +147,29 @@ M: x86.32 %prepare-jump
M:: x86.32 %unbox ( dst src func rep -- ) M:: x86.32 %unbox ( dst src func rep -- )
src func call-unbox-func src func call-unbox-func
dst ?spill-slot rep store-return-reg ; dst rep %load-return ;
M:: x86.32 %store-return ( src rep -- ) M:: x86.32 %box ( dst src func rep -- )
src ?spill-slot rep load-return-reg ;
M:: x86.32 %store-long-long-return ( src1 src2 -- )
src2 EAX = [ src1 src2 XCHG src2 src1 ] [ src1 src2 ] if :> ( src1 src2 )
EAX src1 int-rep %copy
EDX src2 int-rep %copy ;
M:: x86.32 %store-struct-return ( src c-type -- )
EAX src int-rep %copy
EDX EAX 4 [+] MOV
EAX EAX [] MOV ;
M: stack-params copy-register*
drop
{
{ [ dup integer? ] [ EAX swap next-stack@ MOV EAX MOV ] }
{ [ over integer? ] [ EAX swap MOV param@ EAX MOV ] }
} cond ;
M: x86.32 %save-param-reg [ local@ ] 2dip %copy ;
: (%box) ( n rep -- )
#! If n is f, push the return register onto the stack; we
#! are boxing a return value of a C function. If n is an
#! integer, push [ESP+n] on the stack; we are boxing a
#! parameter being passed to a callback from C.
over [ [ local@ ] dip load-return-reg ] [ 2drop ] if ;
M:: x86.32 %box ( dst n rep func -- )
n rep (%box)
rep rep-size save-vm-ptr rep rep-size save-vm-ptr
0 stack@ rep store-return-reg src rep %store-return
0 stack@ rep %load-return
func f %alien-invoke func f %alien-invoke
dst EAX tagged-rep %copy ; dst EAX tagged-rep %copy ;
: (%box-long-long) ( n -- ) M:: x86.32 %box-long-long ( dst src1 src2 func -- )
[
[ EDX swap next-stack@ MOV ]
[ EAX swap cell - next-stack@ MOV ] bi
] when* ;
M:: x86.32 %box-long-long ( dst n func -- )
n (%box-long-long)
8 save-vm-ptr 8 save-vm-ptr
4 stack@ EDX MOV 4 stack@ src1 int-rep %copy
0 stack@ EAX MOV 0 stack@ src2 int-rep %copy
func f %alien-invoke func f %alien-invoke
dst EAX tagged-rep %copy ; dst EAX tagged-rep %copy ;
M: x86.32 struct-return@ ( n -- operand ) M:: x86.32 %allot-byte-array ( dst size -- )
[ next-stack@ ] [ stack-frame get params>> local@ ] if* ; 4 save-vm-ptr
0 stack@ size MOV
M:: x86.32 %box-large-struct ( dst n c-type -- ) "allot_byte_array" f %alien-invoke
EDX n struct-return@ LEA
8 save-vm-ptr
4 stack@ c-type heap-size MOV
0 stack@ EDX MOV
"from_value_struct" f %alien-invoke
dst EAX tagged-rep %copy ; dst EAX tagged-rep %copy ;
M:: x86.32 %box-small-struct ( dst c-type -- ) M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
#! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
12 save-vm-ptr
8 stack@ c-type heap-size MOV
4 stack@ EDX MOV
0 stack@ EAX MOV
"from_small_struct" f %alien-invoke
dst EAX tagged-rep %copy ;
M: x86.32 %begin-callback ( -- ) M: x86.32 %begin-callback ( -- )
0 save-vm-ptr 0 save-vm-ptr
@ -309,7 +247,7 @@ M: x86.32 long-long-on-stack? t ;
M: x86.32 float-on-stack? t ; M: x86.32 float-on-stack? t ;
M: x86.32 flatten-struct-type M: x86.32 flatten-struct-type
stack-size cell /i { int-rep t } <repetition> ; call-next-method [ first t 2array ] map ;
M: x86.32 struct-return-on-stack? os linux? not ; M: x86.32 struct-return-on-stack? os linux? not ;

5
basis/cpu/x86/64/64-tests.factor
View File

@ -1,5 +1,6 @@
USING: alien alien.c-types cpu.architecture cpu.x86.64 USING: alien alien.c-types cpu.architecture cpu.x86.64
cpu.x86.assembler cpu.x86.assembler.operands tools.test ; cpu.x86.assembler cpu.x86.assembler.operands tools.test
assocs sequences ;
IN: cpu.x86.64.tests IN: cpu.x86.64.tests
: assembly-test-1 ( -- x ) int { } cdecl [ RAX 3 MOV ] alien-assembly ; : assembly-test-1 ( -- x ) int { } cdecl [ RAX 3 MOV ] alien-assembly ;
@ -9,7 +10,7 @@ IN: cpu.x86.64.tests
: assembly-test-2 ( a b -- x ) : assembly-test-2 ( a b -- x )
int { int int } cdecl [ int { int int } cdecl [
param-reg-0 param-reg-1 ADD param-reg-0 param-reg-1 ADD
int-regs return-reg param-reg-0 MOV int-regs return-regs at first param-reg-0 MOV
] alien-assembly ; ] alien-assembly ;
[ 23 ] [ 17 6 assembly-test-2 ] unit-test [ 23 ] [ 17 6 assembly-test-2 ] unit-test

122
basis/cpu/x86/64/64.factor
View File

@ -11,15 +11,20 @@ cpu.architecture vm ;
FROM: layouts => cell cells ; FROM: layouts => cell cells ;
IN: cpu.x86.64 IN: cpu.x86.64
: param-reg-0 ( -- reg ) 0 int-regs cdecl param-reg ; inline : param-reg ( n -- reg ) int-regs cdecl param-regs at nth ;
: param-reg-1 ( -- reg ) 1 int-regs cdecl param-reg ; inline
: param-reg-2 ( -- reg ) 2 int-regs cdecl param-reg ; inline : param-reg-0 ( -- reg ) 0 param-reg ; inline
: param-reg-3 ( -- reg ) 3 int-regs cdecl param-reg ; inline : param-reg-1 ( -- reg ) 1 param-reg ; inline
: param-reg-2 ( -- reg ) 2 param-reg ; inline
: param-reg-3 ( -- reg ) 3 param-reg ; inline
M: x86.64 pic-tail-reg RBX ; M: x86.64 pic-tail-reg RBX ;
M: int-regs return-reg drop RAX ; M: x86.64 return-regs
M: float-regs return-reg drop XMM0 ; {
{ int-regs { RAX EDX } }
{ float-regs { XMM0 XMM1 } }
} ;
M: x86.64 ds-reg R14 ; M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ; M: x86.64 rs-reg R15 ;
@ -49,18 +54,16 @@ M: x86.64 %vm-field ( dst offset -- )
M:: x86.64 %load-vector ( dst val rep -- ) M:: x86.64 %load-vector ( dst val rep -- )
dst 0 [RIP+] rep copy-memory* val rc-relative rel-binary-literal ; dst 0 [RIP+] rep copy-memory* val rc-relative rel-binary-literal ;
M: x86.64 %load-float ( dst val -- )
<float> float-rep %load-vector ;
M: x86.64 %load-double ( dst val -- )
<double> double-rep %load-vector ;
M: x86.64 %set-vm-field ( src offset -- ) M: x86.64 %set-vm-field ( src offset -- )
[ vm-reg ] dip [+] swap MOV ; [ vm-reg ] dip [+] swap MOV ;
M: x86.64 %vm-field-ptr ( dst offset -- ) M: x86.64 %vm-field-ptr ( dst offset -- )
[ vm-reg ] dip [+] LEA ; [ vm-reg ] dip [+] LEA ;
! Must be a volatile register not used for parameter passing or
! integer return
HOOK: temp-reg cpu ( -- reg )
M: x86.64 %prologue ( n -- ) M: x86.64 %prologue ( n -- )
temp-reg -7 [RIP+] LEA temp-reg -7 [RIP+] LEA
dup PUSH dup PUSH
@ -99,85 +102,29 @@ M:: x86.64 %dispatch ( src temp -- )
[ (align-code) ] [ (align-code) ]
bi ; bi ;
M:: x86.64 %load-reg-param ( dst reg rep -- )
dst reg rep %copy ;
M:: x86.64 %store-reg-param ( src reg rep -- )
reg src rep %copy ;
M:: x86.64 %unbox ( dst src func rep -- ) M:: x86.64 %unbox ( dst src func rep -- )
param-reg-0 src tagged-rep %copy param-reg-0 src tagged-rep %copy
param-reg-1 %mov-vm-ptr param-reg-1 %mov-vm-ptr
func f %alien-invoke func f %alien-invoke
dst rep reg-class-of return-reg rep %copy ; dst rep %load-return ;
: with-return-regs ( quot -- ) M:: x86.64 %box ( dst src func rep -- )
[ 0 rep reg-class-of cdecl param-regs at nth src rep %copy
V{ RDX RAX } clone int-regs set
V{ XMM1 XMM0 } clone float-regs set
call
] with-scope ; inline
: each-struct-component ( c-type quot -- )
'[
flatten-struct-type
[ [ first ] dip @ ] each-index
] with-return-regs ; inline
: %unbox-struct-component ( rep i -- )
R11 swap cells [+] swap reg-class-of {
{ int-regs [ int-regs get pop swap MOV ] }
{ float-regs [ float-regs get pop swap MOVSD ] }
} case ;
M:: x86.64 %store-return ( src rep -- )
rep reg-class-of return-reg src rep %copy ;
M:: x86.64 %store-struct-return ( src c-type -- )
! Move src to R11 so that we don't clobber it.
R11 src int-rep %copy
c-type [ %unbox-struct-component ] each-struct-component ;
M: stack-params copy-register*
drop
{
{ [ dup integer? ] [ R11 swap next-stack@ MOV R11 MOV ] }
{ [ over integer? ] [ R11 swap MOV param@ R11 MOV ] }
} cond ;
M: x86.64 %save-param-reg [ param@ ] 2dip %copy ;
M:: x86.64 %box ( dst n rep func -- )
0 rep reg-class-of cdecl param-reg
n [ n param@ ] [ rep reg-class-of return-reg ] if rep %copy
rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr
func f %alien-invoke func f %alien-invoke
dst RAX tagged-rep %copy ; dst int-rep %load-return ;
: box-struct-component@ ( i -- operand ) 1 + cells param@ ; M:: x86.64 %allot-byte-array ( dst size -- )
param-reg-0 size MOV
: %box-struct-component ( rep i -- ) param-reg-1 %mov-vm-ptr
box-struct-component@ swap reg-class-of { "allot_byte_array" f %alien-invoke
{ int-regs [ int-regs get pop MOV ] } dst int-rep %load-return ;
{ float-regs [ float-regs get pop MOVSD ] }
} case ;
M:: x86.64 %box-small-struct ( dst c-type -- )
#! Box a <= 16-byte struct.
c-type [ %box-struct-component ] each-struct-component
param-reg-2 c-type heap-size MOV
param-reg-0 0 box-struct-component@ MOV
param-reg-1 1 box-struct-component@ MOV
param-reg-3 %mov-vm-ptr
"from_small_struct" f %alien-invoke
dst RAX tagged-rep %copy ;
M: x86.64 struct-return@ ( n -- operand )
[ stack-frame get params>> ] unless* param@ ;
M:: x86.64 %box-large-struct ( dst n c-type -- )
! Struct size is parameter 2
param-reg-1 c-type heap-size MOV
! Compute destination address
param-reg-0 n struct-return@ LEA
param-reg-2 %mov-vm-ptr
! Copy the struct from the C stack
"from_value_struct" f %alien-invoke
dst RAX tagged-rep %copy ;
M: x86.64 %alien-invoke M: x86.64 %alien-invoke
R11 0 MOV R11 0 MOV
@ -198,15 +145,12 @@ M: x86.64 %end-callback ( -- )
"end_callback" f %alien-invoke ; "end_callback" f %alien-invoke ;
: float-function-param ( i src -- ) : float-function-param ( i src -- )
[ float-regs cdecl param-regs nth ] dip double-rep %copy ; [ float-regs cdecl param-regs at nth ] dip double-rep %copy ;
: float-function-return ( reg -- )
float-regs return-reg double-rep %copy ;
M:: x86.64 %unary-float-function ( dst src func -- ) M:: x86.64 %unary-float-function ( dst src func -- )
0 src float-function-param 0 src float-function-param
func "libm" load-library %alien-invoke func "libm" load-library %alien-invoke
dst float-function-return ; dst double-rep %load-return ;
M:: x86.64 %binary-float-function ( dst src1 src2 func -- ) M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
! src1 might equal dst; otherwise it will be a spill slot ! src1 might equal dst; otherwise it will be a spill slot
@ -214,7 +158,7 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
0 src1 float-function-param 0 src1 float-function-param
1 src2 float-function-param 1 src2 float-function-param
func "libm" load-library %alien-invoke func "libm" load-library %alien-invoke
dst float-function-return ; dst double-rep %load-return ;
M:: x86.64 %call-gc ( gc-roots -- ) M:: x86.64 %call-gc ( gc-roots -- )
param-reg-0 gc-roots gc-root-offsets %load-reference param-reg-0 gc-roots gc-root-offsets %load-reference

18
basis/cpu/x86/64/unix/unix.factor
View File

@ -3,14 +3,18 @@
USING: accessors arrays sequences math splitting make assocs USING: accessors arrays sequences math splitting make assocs
kernel layouts system alien.c-types classes.struct kernel layouts system alien.c-types classes.struct
cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands
cpu.x86 compiler.cfg.builder.alien compiler.cfg.registers ; cpu.x86 cpu.x86.64 compiler.cfg.builder.alien
compiler.cfg.builder.alien.boxing compiler.cfg.registers ;
IN: cpu.x86.64.unix IN: cpu.x86.64.unix
M: int-regs param-regs M: int-regs param-regs
2drop { RDI RSI RDX RCX R8 R9 } ; 2drop { RDI RSI RDX RCX R8 R9 } ;
M: float-regs param-regs M: x86.64 param-regs
2drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ; drop {
{ int-regs { RDI RSI RDX RCX R8 R9 } }
{ float-regs { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } }
} ;
M: x86.64 reserved-stack-space 0 ; M: x86.64 reserved-stack-space 0 ;
@ -31,13 +35,9 @@ M: x86.64 reserved-stack-space 0 ;
f 2array f 2array
] map ; ] map ;
: flatten-large-struct ( c-type -- seq )
stack-size cell /i { int-rep t } <repetition> ;
M: x86.64 flatten-struct-type ( c-type -- seq ) M: x86.64 flatten-struct-type ( c-type -- seq )
dup heap-size 16 > dup heap-size 16 <=
[ flatten-large-struct ] [ flatten-small-struct ] [ call-next-method [ first t 2array ] map ] if ;
[ flatten-small-struct ] if ;
M: x86.64 return-struct-in-registers? ( c-type -- ? ) M: x86.64 return-struct-in-registers? ( c-type -- ? )
heap-size 2 cells <= ; heap-size 2 cells <= ;

15
basis/cpu/x86/64/winnt/winnt.factor
View File

@ -1,13 +1,15 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel layouts system math alien.c-types sequences USING: kernel layouts system math alien.c-types sequences
compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86 compiler.cfg.registers cpu.architecture cpu.x86.assembler
cpu.x86.assembler.operands ; cpu.x86 cpu.x86.64 cpu.x86.assembler.operands ;
IN: cpu.x86.64.winnt IN: cpu.x86.64.winnt
M: int-regs param-regs 2drop { RCX RDX R8 R9 } ; M: x86.64 param-regs
drop {
M: float-regs param-regs 2drop { XMM0 XMM1 XMM2 XMM3 } ; { int-regs { RCX RDX R8 R9 } }
{ float-regs { XMM0 XMM1 XMM2 XMM3 } }
} ;
M: x86.64 reserved-stack-space 4 cells ; M: x86.64 reserved-stack-space 4 cells ;
@ -23,4 +25,3 @@ M: x86.64 dummy-int-params? t ;
M: x86.64 dummy-fp-params? t ; M: x86.64 dummy-fp-params? t ;
M: x86.64 temp-reg R11 ; M: x86.64 temp-reg R11 ;

27
basis/cpu/x86/features/features.factor
View File

@ -1,13 +1,16 @@
! Copyright (C) 2009, 2010 Slava Pestov. ! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types combinators compiler USING: accessors assocs sequences alien alien.c-types
compiler.codegen.fixup compiler.units cpu.architecture combinators compiler compiler.codegen.fixup compiler.units
cpu.x86.assembler cpu.x86.assembler.operands init io kernel cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands
locals math math.order math.parser memoize namespaces system ; init io kernel locals math math.order math.parser memoize
namespaces system ;
IN: cpu.x86.features IN: cpu.x86.features
<PRIVATE <PRIVATE
: return-reg ( -- reg ) int-regs return-regs at first ;
: (sse-version) ( -- n ) : (sse-version) ( -- n )
int { } cdecl [ int { } cdecl [
"sse-42" define-label "sse-42" define-label
@ -18,7 +21,7 @@ IN: cpu.x86.features
"sse-1" define-label "sse-1" define-label
"end" define-label "end" define-label
int-regs return-reg 1 MOV return-reg 1 MOV
CPUID CPUID
@ -40,31 +43,31 @@ IN: cpu.x86.features
EDX 25 BT EDX 25 BT
"sse-1" get JB "sse-1" get JB
int-regs return-reg 0 MOV return-reg 0 MOV
"end" get JMP "end" get JMP
"sse-42" resolve-label "sse-42" resolve-label
int-regs return-reg 42 MOV return-reg 42 MOV
"end" get JMP "end" get JMP
"sse-41" resolve-label "sse-41" resolve-label
int-regs return-reg 41 MOV return-reg 41 MOV
"end" get JMP "end" get JMP
"ssse-3" resolve-label "ssse-3" resolve-label
int-regs return-reg 33 MOV return-reg 33 MOV
"end" get JMP "end" get JMP
"sse-3" resolve-label "sse-3" resolve-label
int-regs return-reg 30 MOV return-reg 30 MOV
"end" get JMP "end" get JMP
"sse-2" resolve-label "sse-2" resolve-label
int-regs return-reg 20 MOV return-reg 20 MOV
"end" get JMP "end" get JMP
"sse-1" resolve-label "sse-1" resolve-label
int-regs return-reg 10 MOV return-reg 10 MOV
"end" resolve-label "end" resolve-label
] alien-assembly ; ] alien-assembly ;

48
basis/cpu/x86/x86.factor
View File

@ -38,11 +38,7 @@ HOOK: extra-stack-space cpu ( stack-frame -- n )
stack-frame get extra-stack-space + stack-frame get extra-stack-space +
reserved-stack-space + ; reserved-stack-space + ;
: special@ ( n -- op ) special-offset stack@ ; : spill@ ( n -- op ) spill-offset special-offset stack@ ;
: spill@ ( n -- op ) spill-offset special@ ;
: param@ ( n -- op ) reserved-stack-space + stack@ ;
: gc-root-offsets ( seq -- seq' ) : gc-root-offsets ( seq -- seq' )
[ n>> spill-offset special-offset cell + ] map f like ; [ n>> spill-offset special-offset cell + ] map f like ;
@ -62,10 +58,6 @@ M: x86 stack-frame-size ( stack-frame -- i )
3 cells + 3 cells +
align-stack ; align-stack ;
! Must be a volatile register not used for parameter passing or
! integer return
HOOK: temp-reg cpu ( -- reg )
HOOK: pic-tail-reg cpu ( -- reg ) HOOK: pic-tail-reg cpu ( -- reg )
M: x86 complex-addressing? t ; M: x86 complex-addressing? t ;
@ -83,6 +75,12 @@ M: x86 %load-reference
[ \ f type-number MOV ] [ \ f type-number MOV ]
if* ; if* ;
M: x86 %load-float ( dst val -- )
<float> float-rep %load-vector ;
M: x86 %load-double ( dst val -- )
<double> double-rep %load-vector ;
HOOK: ds-reg cpu ( -- reg ) HOOK: ds-reg cpu ( -- reg )
HOOK: rs-reg cpu ( -- reg ) HOOK: rs-reg cpu ( -- reg )
@ -1500,16 +1498,27 @@ M:: x86 %spill ( src rep dst -- )
M:: x86 %reload ( dst rep src -- ) M:: x86 %reload ( dst rep src -- )
dst src rep %copy ; dst src rep %copy ;
M:: x86 %store-reg-param ( src reg rep -- )
reg src rep %copy ;
M:: x86 %store-stack-param ( src n rep -- ) M:: x86 %store-stack-param ( src n rep -- )
n param@ src rep %copy ; n reserved-stack-space + stack@ src rep %copy ;
HOOK: struct-return@ cpu ( n -- operand ) : %load-return ( dst rep -- )
[ reg-class-of return-regs at first ] keep %load-reg-param ;
M: x86 %prepare-struct-area ( dst -- ) : %store-return ( dst rep -- )
f struct-return@ LEA ; [ reg-class-of return-regs at first ] keep %store-reg-param ;
: next-stack@ ( n -- operand )
#! nth parameter from the next stack frame. Used to box
#! input values to callbacks; the callback has its own
#! stack frame set up, and we want to read the frame
#! set up by the caller.
frame-reg swap 2 cells + [+] ;
M:: x86 %load-stack-param ( dst n rep -- )
dst n next-stack@ rep %copy ;
M: x86 %prepare-struct-caller ( dst -- )
return-offset special-offset stack@ LEA ;
M: x86 %alien-indirect ( src -- ) M: x86 %alien-indirect ( src -- )
?spill-slot CALL ; ?spill-slot CALL ;
@ -1540,13 +1549,6 @@ M: x86 immediate-arithmetic? ( n -- ? )
M: x86 immediate-bitwise? ( n -- ? ) M: x86 immediate-bitwise? ( n -- ? )
HEX: -80000000 HEX: 7fffffff between? ; HEX: -80000000 HEX: 7fffffff between? ;
: next-stack@ ( n -- operand )
#! nth parameter from the next stack frame. Used to box
#! input values to callbacks; the callback has its own
#! stack frame set up, and we want to read the frame
#! set up by the caller.
frame-reg swap 2 cells + [+] ;
enable-min/max enable-min/max
enable-log2 enable-log2

12
basis/math/floats/env/x86/64/64.factor vendored
View File

@ -1,25 +1,25 @@
USING: alien alien.c-types cpu.architecture cpu.x86.assembler USING: alien alien.c-types cpu.x86.64 cpu.x86.assembler
cpu.x86.assembler.operands math.floats.env.x86 sequences system ; cpu.x86.assembler.operands math.floats.env.x86 sequences system ;
IN: math.floats.env.x86.64 IN: math.floats.env.x86.64
M: x86.64 get-sse-env M: x86.64 get-sse-env
void { void* } cdecl [ void { void* } cdecl [
int-regs cdecl param-regs first [] STMXCSR param-reg-0 [] STMXCSR
] alien-assembly ; ] alien-assembly ;
M: x86.64 set-sse-env M: x86.64 set-sse-env
void { void* } cdecl [ void { void* } cdecl [
int-regs cdecl param-regs first [] LDMXCSR param-reg-0 [] LDMXCSR
] alien-assembly ; ] alien-assembly ;
M: x86.64 get-x87-env M: x86.64 get-x87-env
void { void* } cdecl [ void { void* } cdecl [
int-regs cdecl param-regs first [] FNSTSW param-reg-0 [] FNSTSW
int-regs cdecl param-regs first 2 [+] FNSTCW param-reg-0 2 [+] FNSTCW
] alien-assembly ; ] alien-assembly ;
M: x86.64 set-x87-env M: x86.64 set-x87-env
void { void* } cdecl [ void { void* } cdecl [
FNCLEX FNCLEX
int-regs cdecl param-regs first 2 [+] FLDCW param-reg-0 2 [+] FLDCW
] alien-assembly ; ] alien-assembly ;

17
basis/stack-checker/alien/alien.factor
View File

@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors combinators math namespaces USING: kernel sequences accessors combinators math namespaces
init sets words assocs alien.libraries alien alien.private init sets words assocs alien.libraries alien alien.private
alien.c-types fry stack-checker.backend alien.c-types fry quotations stack-checker.backend
stack-checker.errors stack-checker.visitor stack-checker.errors stack-checker.visitor
stack-checker.dependencies ; stack-checker.dependencies compiler.utilities ;
IN: stack-checker.alien IN: stack-checker.alien
TUPLE: alien-node-params return parameters abi in-d out-d ; TUPLE: alien-node-params return parameters abi in-d out-d ;
@ -104,6 +104,18 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
: callback-bottom ( params -- ) : callback-bottom ( params -- )
xt>> '[ _ callback-xt ] infer-quot-here ; xt>> '[ _ callback-xt ] infer-quot-here ;
: callback-return-quot ( ctype -- quot )
return>> [ [ ] ] [ c-type c-type-unboxer-quot ] if-void ;
: callback-prep-quot ( params -- quot )
parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
: wrap-callback-quot ( params -- quot )
[ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append
yield-hook get
'[ _ _ do-callback ]
>quotation ;
: infer-alien-callback ( -- ) : infer-alien-callback ( -- )
alien-callback-params new alien-callback-params new
pop-quot pop-quot
@ -111,5 +123,6 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
pop-params pop-params
pop-return pop-return
"( callback )" <uninterned-word> >>xt "( callback )" <uninterned-word> >>xt
dup wrap-callback-quot >>quot
dup callback-bottom dup callback-bottom
#alien-callback, ; #alien-callback, ;

43
vm/alien.cpp
View File

@ -187,47 +187,4 @@ VM_C_API char *alien_offset(cell obj, factor_vm *parent)
return parent->alien_offset(obj); return parent->alien_offset(obj);
} }
/* For FFI callbacks receiving structs by value */
cell factor_vm::from_value_struct(void *src, cell size)
{
byte_array *bytes = allot_byte_array(size);
memcpy(bytes->data<void>(),src,size);
return tag<byte_array>(bytes);
}
VM_C_API cell from_value_struct(void *src, cell size, factor_vm *parent)
{
return parent->from_value_struct(src,size);
}
/* On some x86 OSes, structs <= 8 bytes are returned in registers. */
cell factor_vm::from_small_struct(cell x, cell y, cell size)
{
cell data[2];
data[0] = x;
data[1] = y;
return from_value_struct(data,size);
}
VM_C_API cell from_small_struct(cell x, cell y, cell size, factor_vm *parent)
{
return parent->from_small_struct(x,y,size);
}
/* On OS X/PPC, complex numbers are returned in registers. */
cell factor_vm::from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size)
{
cell data[4];
data[0] = x1;
data[1] = x2;
data[2] = x3;
data[3] = x4;
return from_value_struct(data,size);
}
VM_C_API cell from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *parent)
{
return parent->from_medium_struct(x1, x2, x3, x4, size);
}
} }

3
vm/alien.hpp
View File

@ -4,8 +4,5 @@ namespace factor
VM_C_API char *alien_offset(cell object, factor_vm *vm); VM_C_API char *alien_offset(cell object, factor_vm *vm);
VM_C_API char *pinned_alien_offset(cell object, factor_vm *vm); VM_C_API char *pinned_alien_offset(cell object, factor_vm *vm);
VM_C_API cell allot_alien(void *address, factor_vm *vm); VM_C_API cell allot_alien(void *address, factor_vm *vm);
VM_C_API cell from_value_struct(void *src, cell size, factor_vm *vm);
VM_C_API cell from_small_struct(cell x, cell y, cell size, factor_vm *vm);
VM_C_API cell from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size, factor_vm *vm);
} }

5
vm/byte_arrays.cpp
View File

@ -10,6 +10,11 @@ byte_array *factor_vm::allot_byte_array(cell size)
return array; return array;
} }
VM_C_API cell allot_byte_array(cell size, factor_vm *parent)
{
return tag<byte_array>(parent->allot_byte_array(size));
}
void factor_vm::primitive_byte_array() void factor_vm::primitive_byte_array()
{ {
cell size = unbox_array_size(); cell size = unbox_array_size();

2
vm/byte_arrays.hpp
View File

@ -20,4 +20,6 @@ template<typename Type> byte_array *factor_vm::byte_array_from_value(Type *value
return data; return data;
} }
VM_C_API cell allot_byte_array(cell size, factor_vm *parent);
} }

3
vm/vm.hpp
View File

@ -615,9 +615,6 @@ struct factor_vm
void primitive_dlclose(); void primitive_dlclose();
void primitive_dll_validp(); void primitive_dll_validp();
char *alien_offset(cell obj); char *alien_offset(cell obj);
cell from_value_struct(void *src, cell size);
cell from_small_struct(cell x, cell y, cell size);
cell from_medium_struct(cell x1, cell x2, cell x3, cell x4, cell size);
// quotations // quotations
void primitive_jit_compile(); void primitive_jit_compile();