M: array base-type drop void* base-type ;
-M: array stack-size drop void* stack-size ;
-
PREDICATE: string-type < pair
first2 [ c-string = ] [ word? ] bi* and ;
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-boxer-quot
}
{ $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>
{ $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" } "." } ;
long ulong
longlong ulonglong
float double
- void* bool
- (stack-value) ;
+ void* bool ;
SINGLETON: void
M: abstract-c-type heap-size size>> ;
-GENERIC: stack-size ( name -- size )
-
-M: c-type stack-size size>> cell align ;
-
MIXIN: value-type
: c-getter ( name -- quot )
c-type-align
c-type-align-first
base-type
- heap-size
- stack-size ;
+ heap-size ;
CONSULT: c-type-protocol c-type-name
c-type ;
object >>boxed-class
\ bool define-primitive-type
- \ void* c-type clone stack-params >>rep
- \ (stack-value) define-primitive-type
-
] with-compilation-unit
M: char-16-rep rep-component-type drop char ;
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 -- ? )
{
{ [ dup void? ] [ drop f ] }
! Copyright (C) 2008, 2010 Slava Pestov.
! 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
compiler.cfg.rpo compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.stack-frame ;
M: ##stack-frame compute-stack-frame*
stack-frame>> request-stack-frame ;
-M: ##call compute-stack-frame* drop frame-required? on ;
-
M: ##call-gc compute-stack-frame*
drop
frame-required? on
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*
class "frame-required?" word-prop
[ frame-required? on ] when ;
: initial-stack-frame ( -- stack-frame )
stack-frame new cfg get spill-area-size>> >>spill-area-size ;
-: compute-stack-frame ( insns -- )
- frame-required? off
+: compute-stack-frame ( cfg -- )
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 ;
: build-stack-frame ( cfg -- cfg )
! Copyright (C) 2008, 2010 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: accessors arrays layouts math math.order math.parser\r
-combinators combinators.short-circuit fry make sequences locals\r
-alien alien.private alien.strings alien.c-types alien.libraries\r
-classes.struct namespaces kernel strings libc quotations words\r
-cpu.architecture compiler.utilities compiler.tree compiler.cfg\r
+combinators combinators.short-circuit fry make sequences\r
+sequences.generalizations alien alien.private alien.strings\r
+alien.c-types alien.libraries classes.struct namespaces kernel\r
+strings libc locals quotations words cpu.architecture\r
+compiler.utilities compiler.tree compiler.cfg\r
compiler.cfg.builder compiler.cfg.builder.alien.params\r
-compiler.cfg.builder.blocks compiler.cfg.instructions\r
-compiler.cfg.stack-frame compiler.cfg.stacks\r
-compiler.cfg.registers compiler.cfg.hats ;\r
+compiler.cfg.builder.alien.boxing compiler.cfg.builder.blocks\r
+compiler.cfg.instructions compiler.cfg.stack-frame\r
+compiler.cfg.stacks compiler.cfg.registers compiler.cfg.hats ;\r
FROM: compiler.errors => no-such-symbol no-such-library ;\r
IN: compiler.cfg.builder.alien\r
\r
-! output is triples with shape { vreg rep on-stack? }\r
-GENERIC: unbox ( src c-type -- vregs )\r
-\r
-M: c-type unbox\r
- [ [ unboxer>> ] [ rep>> ] bi ^^unbox ] [ rep>> ] bi\r
- f 3array 1array ;\r
-\r
-M: long-long-type unbox\r
- unboxer>> int-rep ^^unbox\r
- 0 cell\r
- [\r
- int-rep f ^^load-memory-imm\r
- int-rep long-long-on-stack? 3array\r
- ] bi-curry@ bi 2array ;\r
-\r
-GENERIC: unbox-parameter ( src c-type -- vregs )\r
-\r
-M: c-type unbox-parameter unbox ;\r
-\r
-M: long-long-type unbox-parameter unbox ;\r
-\r
-M:: struct-c-type unbox-parameter ( src c-type -- )\r
- src ^^unbox-any-c-ptr :> src\r
- c-type value-struct? [\r
- c-type flatten-struct-type\r
- [| pair i |\r
- src i cells pair first f ^^load-memory-imm\r
- pair first2 3array\r
- ] map-index\r
- ] [ { { src int-rep f } } ] if ;\r
-\r
-: unbox-parameters ( parameters -- vregs )\r
+: unbox-parameters ( parameters -- vregs reps )\r
[\r
[ length iota <reversed> ] keep\r
- [\r
- [ <ds-loc> ^^peek ] [ base-type ] bi*\r
- unbox-parameter\r
- ] 2map concat\r
+ [ [ <ds-loc> ^^peek ] [ base-type ] bi* unbox-parameter ]\r
+ 2 2 mnmap [ concat ] bi@\r
]\r
[ length neg ##inc-d ] bi ;\r
\r
-: prepare-struct-area ( vregs return -- vregs )\r
- #! Return offset on C stack where to store unboxed\r
- #! parameters. If the C function is returning a structure,\r
- #! the first parameter is an implicit target area pointer,\r
- #! so we need to use a different offset.\r
+: prepare-struct-caller ( vregs reps return -- vregs' reps' )\r
large-struct? [\r
- ^^prepare-struct-area int-rep struct-return-on-stack?\r
- 3array prefix\r
+ [ ^^prepare-struct-caller prefix ]\r
+ [ int-rep struct-return-on-stack? 2array prefix ] bi*\r
] when ;\r
\r
-: (objects>registers) ( vregs -- )\r
+: caller-parameter ( vreg rep on-stack? -- insn )\r
+ [ dup reg-class-of reg-class-full? ] dip or\r
+ [ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ]\r
+ [ [ next-reg-param ] keep \ ##store-reg-param new-insn ]\r
+ if ;\r
+\r
+: (caller-parameters) ( vregs reps -- )\r
! Place ##store-stack-param instructions first. This ensures\r
! that no registers are used after the ##store-reg-param\r
! instructions.\r
- [\r
- first3 [ dup reg-class-of reg-class-full? ] dip or\r
- [ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ]\r
- [ [ next-reg-param ] keep \ ##store-reg-param new-insn ]\r
- if\r
- ] map [ ##store-stack-param? ] partition [ % ] bi@ ;\r
+ [ first2 caller-parameter ] 2map\r
+ [ ##store-stack-param? ] partition [ % ] bi@ ;\r
\r
-: objects>registers ( params -- stack-size )\r
+: caller-parameters ( params -- stack-size )\r
[ abi>> ] [ parameters>> ] [ return>> ] tri\r
'[ \r
_ unbox-parameters\r
- _ prepare-struct-area\r
- (objects>registers)\r
+ _ prepare-struct-caller\r
+ (caller-parameters)\r
stack-params get\r
] with-param-regs ;\r
\r
-GENERIC: box-return ( c-type -- dst )\r
-\r
-M: c-type box-return\r
- [ f ] dip [ rep>> ] [ boxer>> ] bi ^^box ;\r
-\r
-M: long-long-type box-return\r
- [ f ] dip boxer>> ^^box-long-long ;\r
-\r
-M: struct-c-type box-return\r
- dup return-struct-in-registers?\r
- [ ^^box-small-struct ] [ [ f ] dip ^^box-large-struct ] if ;\r
-\r
: box-return* ( node -- )\r
return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;\r
\r
bi 2dup check-dlsym ;\r
\r
: return-size ( c-type -- n )\r
- #! Amount of space we reserve for a return value.\r
- {\r
- { [ dup void? ] [ drop 0 ] }\r
- { [ dup base-type struct-c-type? not ] [ drop 0 ] }\r
- { [ dup large-struct? not ] [ drop 2 cells ] }\r
- [ heap-size ]\r
- } cond ;\r
+ ! Amount of space we reserve for a return value.\r
+ dup large-struct? [ heap-size ] [ drop 0 ] if ;\r
\r
: alien-node-height ( params -- )\r
[ out-d>> length ] [ in-d>> length ] bi - adjust-d ;\r
M: #alien-invoke emit-node\r
[\r
{\r
- [ objects>registers ]\r
+ [ caller-parameters ]\r
[ alien-invoke-dlsym ##alien-invoke ]\r
[ emit-stack-frame ]\r
[ box-return* ]\r
node [\r
D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src\r
{\r
- [ objects>registers ]\r
+ [ caller-parameters ]\r
[ drop src ##alien-indirect ]\r
[ emit-stack-frame ]\r
[ box-return* ]\r
M: #alien-assembly emit-node\r
[\r
{\r
- [ objects>registers ]\r
+ [ caller-parameters ]\r
[ quot>> ##alien-assembly ]\r
[ emit-stack-frame ]\r
[ box-return* ]\r
} cleave\r
] emit-alien-block ;\r
\r
-GENERIC: box-parameter ( n c-type -- dst )\r
-\r
-M: c-type box-parameter\r
- [ rep>> ] [ boxer>> ] bi ^^box ;\r
-\r
-M: long-long-type box-parameter\r
- boxer>> ^^box-long-long ;\r
-\r
-: if-value-struct ( ctype true false -- )\r
- [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline\r
-\r
-M: struct-c-type box-parameter\r
- [ ^^box-large-struct ] [ base-type box-parameter ] if-value-struct ;\r
-\r
-: parameter-offsets ( types -- offsets )\r
- 0 [ stack-size + ] accumulate nip ;\r
-\r
-: prepare-parameters ( parameters -- offsets types indices )\r
- [ length iota <reversed> ] [ parameter-offsets ] [ ] tri ;\r
+: callee-parameter ( rep on-stack? -- dst insn )\r
+ [ next-vreg dup ] 2dip\r
+ [ dup reg-class-of reg-class-full? ] dip or\r
+ [ [ alloc-stack-param ] keep \ ##load-stack-param new-insn ]\r
+ [ [ next-reg-param ] keep \ ##load-reg-param new-insn ]\r
+ if ;\r
\r
-: alien-parameters ( params -- seq )\r
- [ parameters>> ] [ return>> large-struct? ] bi\r
- [ struct-return-on-stack? (stack-value) void* ? prefix ] when ;\r
+: prepare-struct-callee ( c-type -- vreg )\r
+ large-struct?\r
+ [ int-rep struct-return-on-stack? callee-parameter , ] [ f ] if ;\r
\r
-: box-parameters ( params -- )\r
- alien-parameters\r
- [ length ##inc-d ]\r
+: (callee-parameters) ( params -- vregs reps )\r
+ [ flatten-parameter-type ] map\r
[\r
- prepare-parameters\r
- [\r
- next-vreg next-vreg ##save-context\r
- base-type box-parameter swap <ds-loc> ##replace\r
- ] 3each\r
- ] bi ;\r
-\r
-:: alloc-parameter ( rep -- reg rep )\r
- rep dup reg-class-of reg-class-full?\r
- [ alloc-stack-param stack-params ] [ [ next-reg-param ] keep ] if ;\r
-\r
-GENERIC: flatten-c-type ( type -- reps )\r
-\r
-M: struct-c-type flatten-c-type\r
- flatten-struct-type [ first2 [ drop stack-params ] when ] map ;\r
- \r
-M: long-long-type flatten-c-type drop { int-rep int-rep } ;\r
-\r
-M: c-type flatten-c-type\r
- rep>> {\r
- { int-rep [ { int-rep } ] }\r
- { float-rep [ float-on-stack? { stack-params } { float-rep } ? ] }\r
- { double-rep [\r
- float-on-stack?\r
- cell 4 = { stack-params stack-params } { stack-params } ?\r
- { double-rep } ?\r
- ] }\r
- { stack-params [ { stack-params } ] }\r
- } case ;\r
- \r
-M: object flatten-c-type base-type flatten-c-type ;\r
-\r
-: flatten-c-types ( types -- reps )\r
- [ flatten-c-type ] map concat ;\r
-\r
-: (registers>objects) ( params -- )\r
- [ 0 ] dip alien-parameters flatten-c-types [\r
- [ alloc-parameter ##save-param-reg ]\r
- [ rep-size cell align + ]\r
- 2bi\r
- ] each drop ; inline\r
-\r
-: registers>objects ( params -- )\r
- ! Generate code for boxing input parameters in a callback.\r
- dup abi>> [\r
- dup (registers>objects)\r
- ##begin-callback\r
- next-vreg next-vreg ##restore-context\r
- box-parameters\r
- ] with-param-regs ;\r
-\r
-: callback-return-quot ( ctype -- quot )\r
- return>> {\r
- { [ dup void? ] [ drop [ ] ] }\r
- { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }\r
- [ c-type c-type-unboxer-quot ]\r
- } cond ;\r
-\r
-: callback-prep-quot ( params -- quot )\r
- parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;\r
+ [ [ first2 callee-parameter ] 1 2 mnmap ] 1 2 mnmap\r
+ concat [ ##load-reg-param? ] partition [ % ] bi@\r
+ ] keep ;\r
\r
-: wrap-callback-quot ( params -- quot )\r
- [ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append\r
- yield-hook get\r
- '[ _ _ do-callback ]\r
- >quotation ;\r
-\r
-GENERIC: unbox-return ( src c-type -- )\r
-\r
-M: c-type unbox-return\r
- unbox first first2 ##store-return ;\r
-\r
-M: long-long-type unbox-return\r
- unbox first2 [ first ] bi@ ##store-long-long-return ;\r
-\r
-M: struct-c-type unbox-return\r
- [ ^^unbox-any-c-ptr ] dip ##store-struct-return ;\r
-\r
-: emit-callback-stack-frame ( params -- )\r
- [ alien-parameters [ stack-size ] map-sum ] [ return>> ] bi\r
- <alien-stack-frame> ##stack-frame ;\r
+: box-parameters ( vregs reps params -- )\r
+ ##begin-callback\r
+ next-vreg next-vreg ##restore-context\r
+ [\r
+ next-vreg next-vreg ##save-context\r
+ box-parameter\r
+ 1 ##inc-d D 0 ##replace\r
+ ] 3each ;\r
\r
-: stack-args-size ( params -- n )\r
- dup abi>> [\r
- alien-parameters flatten-c-types\r
- [ alloc-parameter 2drop ] each\r
+: callee-parameters ( params -- stack-size )\r
+ [ abi>> ] [ return>> ] [ parameters>> ] tri\r
+ '[ \r
+ _ prepare-struct-callee struct-return-area set\r
+ _ [ base-type ] map [ (callee-parameters) ] [ box-parameters ] bi\r
stack-params get\r
- ] with-param-regs ;\r
+ struct-return-area get\r
+ ] with-param-regs\r
+ struct-return-area set ;\r
\r
-: callback-stack-cleanup ( params -- )\r
- [ xt>> ] [ [ stack-args-size ] [ return>> ] [ abi>> ] tri stack-cleanup ] bi\r
+: callback-stack-cleanup ( stack-size params -- )\r
+ [ nip xt>> ] [ [ return>> ] [ abi>> ] bi stack-cleanup ] 2bi\r
"stack-cleanup" set-word-prop ;\r
\r
M: #alien-callback emit-node\r
##prologue\r
[\r
{\r
- [ registers>objects ]\r
- [ emit-callback-stack-frame ]\r
- [ callback-stack-cleanup ]\r
- [ wrap-callback-quot ##alien-callback ]\r
+ [ callee-parameters ]\r
+ [ quot>> ##alien-callback ]\r
[\r
- return>> {\r
- { [ dup void? ] [ drop ##end-callback ] }\r
- { [ dup large-struct? ] [ drop ##end-callback ] }\r
- [\r
- [ D 0 ^^peek ] dip\r
- ##end-callback\r
- base-type unbox-return\r
- ]\r
- } cond\r
+ return>> [ ##end-callback ] [\r
+ [ D 0 ^^peek ] dip\r
+ ##end-callback\r
+ base-type unbox-return\r
+ ] if-void\r
]\r
+ [ callback-stack-cleanup ]\r
} cleave\r
] emit-alien-block\r
##epilogue\r
--- /dev/null
+Slava Pestov
--- /dev/null
+! 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 ;
! Copyright (C) 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: cpu.architecture fry kernel layouts math math.order
-namespaces sequences vectors ;
+namespaces sequences vectors assocs ;
IN: compiler.cfg.builder.alien.params
+SYMBOL: stack-params
+
: alloc-stack-param ( rep -- n )
stack-params get
[ rep-size cell align stack-params +@ ] dip ;
GENERIC: next-reg-param ( rep -- reg )
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
- [ ?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
- [ ?dummy-stack-params ] [ ?dummy-int-params ] bi float-regs get pop ;
-
-GENERIC: reg-class-full? ( reg-class -- ? )
-
-M: stack-params reg-class-full? drop t ;
+ [ ?dummy-stack-params ] [ ?dummy-int-params ] bi
+ float-regs get pop ;
-M: reg-class reg-class-full? get empty? ;
+: reg-class-full? ( reg-class -- ? ) get empty? ;
: 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 -- )
- '[
- [ int-regs init-reg-class ]
- [ float-regs init-reg-class ] bi
- 0 stack-params set
- @
- ] with-scope ; inline
+ '[ param-regs init-regs 0 stack-params set @ ] with-scope ; inline
+
+: next-return-reg ( rep -- reg ) reg-class-of get pop ;
+
+: with-return-regs ( quot -- )
+ '[ return-regs init-regs @ ] with-scope ; inline
use: src
literal: n rep ;
-INSN: ##store-return
-use: src
-literal: rep ;
-
-INSN: ##store-struct-return
-use: src/int-rep
-literal: c-type ;
+INSN: ##load-reg-param
+def: dst
+literal: reg rep ;
-INSN: ##store-long-long-return
-use: src1/int-rep src2/int-rep ;
+INSN: ##load-stack-param
+def: dst
+literal: n rep ;
-INSN: ##prepare-struct-area
+INSN: ##prepare-struct-caller
def: dst/int-rep ;
INSN: ##box
def: dst/tagged-rep
-literal: n rep boxer ;
+use: src
+literal: boxer rep ;
INSN: ##box-long-long
def: dst/tagged-rep
-literal: n boxer ;
-
-INSN: ##box-small-struct
-def: dst/tagged-rep
-literal: c-type ;
+use: src1/int-rep src2/int-rep
+literal: boxer ;
-INSN: ##box-large-struct
+INSN: ##allot-byte-array
def: dst/tagged-rep
-literal: n c-type ;
+literal: size ;
INSN: ##alien-invoke
literal: symbols dll ;
INSN: ##alien-assembly
literal: quot ;
-INSN: ##save-param-reg
-literal: offset reg rep ;
-
INSN: ##begin-callback ;
INSN: ##alien-callback
UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
-! Instructions that clobber registers
-UNION: clobber-insn
-##call-gc
-##unary-float-function
-##binary-float-function
-##box
-##box-long-long
-##box-small-struct
-##box-large-struct
-##unbox
+! Instructions that clobber registers. They receive inputs and
+! produce outputs in spill slots.
+UNION: hairy-clobber-insn
+##load-reg-param
##store-reg-param
-##store-return
-##store-struct-return
-##store-long-long-return
+##call-gc
##alien-invoke
##alien-indirect
##alien-assembly
-##save-param-reg
##begin-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
! output registers are not equal to any of the input registers
UNION: def-is-use-insn
[ drop assign-blocked-register ]
} cond ;
-: spill-at-sync-point ( n live-interval -- ? )
- ! If the live interval has a definition at 'n', don't spill
- 2dup find-use
- { [ ] [ def-rep>> ] } 1&&
- [ 2drop t ] [ swap spill f ] if ;
+: spill-at-sync-point? ( sync-point live-interval -- ? )
+ ! If the live interval has a definition at a keep-dst?
+ ! sync-point, don't spill.
+ {
+ [ drop keep-dst?>> not ]
+ [ [ n>> ] dip find-use dup [ def-rep>> ] when not ]
+ } 2|| ;
+
+: 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 ;
-: handle-sync-point ( n -- )
+M: sync-point handle-progress*
active-intervals get values
[ [ spill-at-sync-point ] with filter! drop ] with each ;
-:: handle-progress ( n sync? -- )
- n {
- [ progress set ]
- [ deactivate-intervals ]
- [ sync? [ handle-sync-point ] [ drop ] if ]
- [ activate-intervals ]
- } cleave ;
+:: handle-progress ( n obj -- )
+ n progress set
+ n deactivate-intervals
+ obj handle-progress*
+ n activate-intervals ;
GENERIC: handle ( obj -- )
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 -- )
- n>> t handle-progress ;
+ [ n>> ] keep handle-progress ;
: smallest-heap ( heap1 heap2 -- heap )
! If heap1 and heap2 have the same key, favors heap1.
] if ;
! A location where all registers have to be spilled
-TUPLE: sync-point n ;
+TUPLE: sync-point n keep-dst? ;
C: <sync-point> sync-point
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*
- insn#>> <sync-point> sync-points get push ;
+ insn#>> t <sync-point> sync-points get push ;
M: insn compute-sync-points* drop ;
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.order namespaces accessors kernel layouts
-combinators combinators.smart assocs sequences cpu.architecture
+combinators assocs sequences cpu.architecture
words compiler.cfg.instructions ;
IN: compiler.cfg.stack-frame
{ calls-vm? boolean } ;
! Stack frame utilities
-: param-base ( -- n )
- stack-frame get [ params>> ] [ return>> ] bi + ;
+: return-offset ( -- offset )
+ stack-frame get params>> ;
: spill-offset ( n -- offset )
- param-base + ;
+ stack-frame get [ params>> ] [ return>> ] bi + + ;
: (stack-frame-size) ( stack-frame -- n )
- [
- [ params>> ] [ return>> ] [ spill-area-size>> ] tri
- ] sum-outputs ;
+ [ params>> ] [ return>> ] [ spill-area-size>> ] tri + + ;
: max-stack-frame ( frame1 frame2 -- frame3 )
[ stack-frame new ] 2dip
CODEGEN: ##unbox %unbox
CODEGEN: ##store-reg-param %store-reg-param
CODEGEN: ##store-stack-param %store-stack-param
-CODEGEN: ##store-return %store-return
-CODEGEN: ##store-struct-return %store-struct-return
-CODEGEN: ##store-long-long-return %store-long-long-return
-CODEGEN: ##prepare-struct-area %prepare-struct-area
+CODEGEN: ##load-reg-param %load-reg-param
+CODEGEN: ##load-stack-param %load-stack-param
+CODEGEN: ##prepare-struct-caller %prepare-struct-caller
CODEGEN: ##box %box
CODEGEN: ##box-long-long %box-long-long
-CODEGEN: ##box-large-struct %box-large-struct
-CODEGEN: ##box-small-struct %box-small-struct
-CODEGEN: ##save-param-reg %save-param-reg
+CODEGEN: ##allot-byte-array %allot-byte-array
CODEGEN: ##alien-invoke %alien-invoke
CODEGEN: ##cleanup %cleanup
CODEGEN: ##alien-indirect %alien-indirect
UNION: reg-class 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 PowerPC they are distinct
HOOK: vector-regs cpu ( -- reg-class )
M: double-rep reg-class-of drop float-regs ;
M: vector-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
M: int-rep rep-size drop cell ;
M: float-rep rep-size drop 4 ;
M: double-rep rep-size drop 8 ;
-M: stack-params rep-size drop cell ;
M: vector-rep rep-size drop 16 ;
M: char-scalar-rep rep-size drop 1 ;
M: uchar-scalar-rep rep-size drop 1 ;
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,
! and %load-vector?
HOOK: fused-unboxing? cpu ( -- ? )
: immediate-shift-count? ( n -- ? )
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?
HOOK: return-struct-in-registers? cpu ( c-type -- ? )
HOOK: %store-stack-param cpu ( src n rep -- )
-HOOK: %store-return cpu ( src rep -- )
-
-HOOK: %store-struct-return cpu ( src reps -- )
-
-HOOK: %store-long-long-return cpu ( src1 src2 -- )
-
-HOOK: %prepare-struct-area cpu ( dst -- )
+HOOK: %prepare-struct-caller cpu ( dst -- )
! Call a function to convert a value into a tagged pointer,
! possibly allocating a bignum, float, or alien instance,
! which is then pushed on the data stack
-HOOK: %box cpu ( dst n rep func -- )
-
-HOOK: %box-long-long cpu ( dst n func -- )
-
-HOOK: %box-small-struct cpu ( dst c-type -- )
+HOOK: %box cpu ( dst src func rep -- )
-HOOK: %box-large-struct cpu ( dst n c-type -- )
+HOOK: %box-long-long cpu ( dst src1 src2 func -- )
-HOOK: %save-param-reg cpu ( stack reg rep -- )
+HOOK: %allot-byte-array cpu ( dst size -- )
HOOK: %restore-context cpu ( temp1 temp2 -- )
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: %alien-callback cpu ( quot -- )
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: 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: integer float-function-param* FMR ;
: 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-regs return-reg double-rep %copy ;
+ float-regs return-regs at first double-rep %copy ;
M:: ppc %unary-float-function ( dst src func -- )
0 src float-function-param
M: ppc %loop-entry ;
-M: int-regs return-reg drop 3 ;
-
-M: int-regs param-regs 2drop { 3 4 5 6 7 8 9 10 } ;
-
-M: float-regs return-reg drop 1 ;
+M: ppc return-regs
+ {
+ { int-regs { 3 4 5 6 } }
+ { float-regs { 1 } }
+ } ;
M:: ppc %save-param-reg ( stack reg rep -- )
reg stack local@ rep store-to-frame ;
M:: ppc %unbox ( src n rep func -- )
src func call-unbox-func
! 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 -- )
src func call-unbox-func
! See http://factorcode.org/license.txt for BSD license.
USING: locals alien alien.c-types alien.libraries alien.syntax
arrays kernel fry math namespaces sequences system layouts io
-vocabs.loader accessors init classes.struct combinators
-make words compiler.constants compiler.codegen.fixup
-compiler.cfg.instructions compiler.cfg.builder compiler.cfg.intrinsics
-compiler.cfg.stack-frame cpu.x86.assembler cpu.x86.assembler.operands
-cpu.x86 cpu.architecture vm ;
+vocabs.loader accessors init classes.struct combinators make
+words compiler.constants compiler.codegen.fixup
+compiler.cfg.instructions compiler.cfg.builder
+compiler.cfg.builder.alien.boxing compiler.cfg.intrinsics
+compiler.cfg.stack-frame cpu.x86.assembler
+cpu.x86.assembler.operands cpu.x86 cpu.architecture vm ;
FROM: layouts => cell ;
IN: cpu.x86.32
M: x86.32 rs-reg EDI ;
M: x86.32 stack-reg ESP ;
M: x86.32 frame-reg EBP ;
-M: x86.32 temp-reg ECX ;
M: x86.32 immediate-comparand? ( obj -- ? ) drop t ;
M:: x86.32 %load-vector ( dst val rep -- )
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 -- )
0 MOV 0 rc-absolute-cell rel-vm ;
M: x86.32 %vm-field-ptr ( dst field -- )
[ 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 %mark-card
M: x86.32 reserved-stack-space 0 ;
-M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
-
: save-vm-ptr ( n -- )
stack@ 0 MOV 0 rc-absolute-cell rel-vm ;
! On x86, parameters are usually never passed in registers,
! except with Microsoft's "thiscall" and "fastcall" abis
-M: int-regs return-reg drop EAX ;
-M: float-regs param-regs 2drop { } ;
-
-M: int-regs param-regs
- nip {
- { thiscall [ { ECX } ] }
- { fastcall [ { ECX EDX } ] }
- [ drop { } ]
+M: x86.32 param-regs
+ {
+ { thiscall [ { { int-regs { ECX } } { float-regs { } } } ] }
+ { fastcall [ { { int-regs { ECX EDX } } { float-regs { } } } ] }
+ [ drop { { int-regs { } } { float-regs { } } } ]
} case ;
-GENERIC: load-return-reg ( src rep -- )
-GENERIC: store-return-reg ( dst rep -- )
+! Need a fake return-reg for floats
+M: x86.32 return-regs
+ {
+ { int-regs { EAX EDX } }
+ { float-regs { f } }
+ } ;
-M: stack-params load-return-reg drop EAX swap MOV ;
-M: stack-params store-return-reg drop EAX MOV ;
+M: x86.32 %prologue ( n -- )
+ dup PUSH
+ 0 PUSH rc-absolute-cell rel-this
+ 3 cells - decr-stack-reg ;
-M: int-rep load-return-reg drop EAX swap MOV ;
-M: int-rep store-return-reg drop EAX MOV ;
+M: x86.32 %prepare-jump
+ pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
-:: load-float-return ( src x87-insn sse-insn -- )
- src register? [
+:: load-float-return ( dst x87-insn sse-insn -- )
+ dst register? [
ESP 4 SUB
- ESP [] src sse-insn execute
ESP [] x87-insn execute
+ dst ESP [] sse-insn execute
ESP 4 ADD
] [
- src x87-insn execute
+ dst x87-insn execute
] if ; inline
-:: store-float-return ( dst x87-insn sse-insn -- )
- dst register? [
+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
- dst ESP [] sse-insn execute
ESP 4 ADD
] [
- dst x87-insn execute
+ src x87-insn execute
] if ; inline
-M: float-rep load-return-reg
- drop \ FLDS \ MOVSS load-float-return ;
-
-M: float-rep store-return-reg
- drop \ FSTPS \ MOVSS store-float-return ;
-
-M: double-rep load-return-reg
- drop \ FLDL \ MOVSD load-float-return ;
-
-M: double-rep store-return-reg
- drop \ FSTPL \ MOVSD store-float-return ;
-
-M: x86.32 %prologue ( n -- )
- dup PUSH
- 0 PUSH rc-absolute-cell rel-this
- 3 cells - decr-stack-reg ;
-
-M: x86.32 %prepare-jump
- pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
+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 -- )
EAX src tagged-rep %copy
M:: x86.32 %unbox ( dst src func rep -- )
src func call-unbox-func
- dst ?spill-slot rep store-return-reg ;
-
-M:: x86.32 %store-return ( src rep -- )
- src ?spill-slot rep load-return-reg ;
-
-M:: x86.32 %store-long-long-return ( src1 src2 -- )
- src2 EAX = [ src1 src2 XCHG src2 src1 ] [ src1 src2 ] if :> ( src1 src2 )
- EAX src1 int-rep %copy
- EDX src2 int-rep %copy ;
+ dst rep %load-return ;
-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)
+M:: x86.32 %box ( dst src func rep -- )
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
dst EAX tagged-rep %copy ;
-: (%box-long-long) ( n -- )
- [
- [ 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)
+M:: x86.32 %box-long-long ( dst src1 src2 func -- )
8 save-vm-ptr
- 4 stack@ EDX MOV
- 0 stack@ EAX MOV
+ 4 stack@ src1 int-rep %copy
+ 0 stack@ src2 int-rep %copy
func f %alien-invoke
dst EAX tagged-rep %copy ;
-M: x86.32 struct-return@ ( n -- operand )
- [ next-stack@ ] [ stack-frame get params>> local@ ] if* ;
-
-M:: x86.32 %box-large-struct ( dst n c-type -- )
- EDX n struct-return@ LEA
- 8 save-vm-ptr
- 4 stack@ c-type heap-size MOV
- 0 stack@ EDX MOV
- "from_value_struct" f %alien-invoke
+M:: x86.32 %allot-byte-array ( dst size -- )
+ 4 save-vm-ptr
+ 0 stack@ size MOV
+ "allot_byte_array" f %alien-invoke
dst EAX tagged-rep %copy ;
-M:: x86.32 %box-small-struct ( dst c-type -- )
- #! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
- 12 save-vm-ptr
- 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 %alien-invoke 0 CALL rc-relative rel-dlsym ;
M: x86.32 %begin-callback ( -- )
0 save-vm-ptr
M: x86.32 float-on-stack? t ;
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 ;
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
: assembly-test-1 ( -- x ) int { } cdecl [ RAX 3 MOV ] alien-assembly ;
: assembly-test-2 ( a b -- x )
int { int int } cdecl [
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 ;
[ 23 ] [ 17 6 assembly-test-2 ] unit-test
FROM: layouts => cell cells ;
IN: cpu.x86.64
-: param-reg-0 ( -- reg ) 0 int-regs cdecl param-reg ; inline
-: param-reg-1 ( -- reg ) 1 int-regs cdecl param-reg ; inline
-: param-reg-2 ( -- reg ) 2 int-regs cdecl param-reg ; inline
-: param-reg-3 ( -- reg ) 3 int-regs cdecl param-reg ; inline
+: param-reg ( n -- reg ) int-regs cdecl param-regs at nth ;
+
+: param-reg-0 ( -- reg ) 0 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: int-regs return-reg drop RAX ;
-M: float-regs return-reg drop XMM0 ;
+M: x86.64 return-regs
+ {
+ { int-regs { RAX EDX } }
+ { float-regs { XMM0 XMM1 } }
+ } ;
M: x86.64 ds-reg R14 ;
M: x86.64 rs-reg R15 ;
M:: x86.64 %load-vector ( dst val rep -- )
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 -- )
[ vm-reg ] dip [+] swap MOV ;
M: x86.64 %vm-field-ptr ( dst offset -- )
[ 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 -- )
temp-reg -7 [RIP+] LEA
dup PUSH
[ (align-code) ]
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 -- )
param-reg-0 src tagged-rep %copy
param-reg-1 %mov-vm-ptr
func f %alien-invoke
- dst rep reg-class-of return-reg rep %copy ;
-
-: with-return-regs ( quot -- )
- [
- V{ RDX RAX } clone int-regs set
- V{ XMM1 XMM0 } clone float-regs set
- call
- ] with-scope ; inline
-
-: each-struct-component ( c-type quot -- )
- '[
- flatten-struct-type
- [ [ first ] dip @ ] each-index
- ] with-return-regs ; inline
-
-: %unbox-struct-component ( rep i -- )
- R11 swap cells [+] swap reg-class-of {
- { int-regs [ int-regs get pop swap MOV ] }
- { float-regs [ float-regs get pop swap MOVSD ] }
- } case ;
-
-M:: x86.64 %store-return ( src rep -- )
- rep reg-class-of return-reg src rep %copy ;
-
-M:: x86.64 %store-struct-return ( src c-type -- )
- ! Move src to R11 so that we don't clobber it.
- R11 src int-rep %copy
- c-type [ %unbox-struct-component ] each-struct-component ;
-
-M: stack-params copy-register*
- drop
- {
- { [ 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 ;
+ dst rep %load-return ;
-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
+M:: x86.64 %box ( dst src func rep -- )
+ 0 rep reg-class-of cdecl param-regs at nth src rep %copy
rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr
func f %alien-invoke
- dst RAX tagged-rep %copy ;
-
-: box-struct-component@ ( i -- operand ) 1 + cells param@ ;
-
-: %box-struct-component ( rep i -- )
- box-struct-component@ swap reg-class-of {
- { int-regs [ int-regs get pop MOV ] }
- { float-regs [ float-regs get pop MOVSD ] }
- } case ;
-
-M:: x86.64 %box-small-struct ( dst c-type -- )
- #! Box a <= 16-byte struct.
- c-type [ %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 ;
+ dst int-rep %load-return ;
+
+M:: x86.64 %allot-byte-array ( dst size -- )
+ param-reg-0 size MOV
+ param-reg-1 %mov-vm-ptr
+ "allot_byte_array" f %alien-invoke
+ dst int-rep %load-return ;
M: x86.64 %alien-invoke
R11 0 MOV
"end_callback" f %alien-invoke ;
: float-function-param ( i src -- )
- [ float-regs cdecl param-regs nth ] dip double-rep %copy ;
-
-: float-function-return ( reg -- )
- float-regs return-reg double-rep %copy ;
+ [ float-regs cdecl param-regs at nth ] dip double-rep %copy ;
M:: x86.64 %unary-float-function ( dst src func -- )
0 src float-function-param
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 -- )
! src1 might equal dst; otherwise it will be a spill slot
0 src1 float-function-param
1 src2 float-function-param
func "libm" load-library %alien-invoke
- dst float-function-return ;
+ dst double-rep %load-return ;
M:: x86.64 %call-gc ( gc-roots -- )
param-reg-0 gc-roots gc-root-offsets %load-reference
USING: accessors arrays sequences math splitting make assocs
kernel layouts system alien.c-types classes.struct
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
M: int-regs param-regs
2drop { RDI RSI RDX RCX R8 R9 } ;
-M: float-regs param-regs
- 2drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
+M: x86.64 param-regs
+ 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 ;
f 2array
] map ;
-: flatten-large-struct ( c-type -- seq )
- stack-size cell /i { int-rep t } <repetition> ;
-
M: x86.64 flatten-struct-type ( c-type -- seq )
- dup heap-size 16 >
- [ flatten-large-struct ]
- [ flatten-small-struct ] if ;
+ dup heap-size 16 <=
+ [ flatten-small-struct ] [ call-next-method [ first t 2array ] map ] if ;
M: x86.64 return-struct-in-registers? ( c-type -- ? )
heap-size 2 cells <= ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel layouts system math alien.c-types sequences
-compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86
-cpu.x86.assembler.operands ;
+compiler.cfg.registers cpu.architecture cpu.x86.assembler
+cpu.x86 cpu.x86.64 cpu.x86.assembler.operands ;
IN: cpu.x86.64.winnt
-M: int-regs param-regs 2drop { RCX RDX R8 R9 } ;
-
-M: float-regs param-regs 2drop { XMM0 XMM1 XMM2 XMM3 } ;
+M: x86.64 param-regs
+ drop {
+ { int-regs { RCX RDX R8 R9 } }
+ { float-regs { XMM0 XMM1 XMM2 XMM3 } }
+ } ;
M: x86.64 reserved-stack-space 4 cells ;
M: x86.64 dummy-fp-params? t ;
M: x86.64 temp-reg R11 ;
-
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types combinators compiler
-compiler.codegen.fixup compiler.units cpu.architecture
-cpu.x86.assembler cpu.x86.assembler.operands init io kernel
-locals math math.order math.parser memoize namespaces system ;
+USING: accessors assocs sequences alien alien.c-types
+combinators compiler compiler.codegen.fixup compiler.units
+cpu.architecture cpu.x86.assembler cpu.x86.assembler.operands
+init io kernel locals math math.order math.parser memoize
+namespaces system ;
IN: cpu.x86.features
<PRIVATE
+: return-reg ( -- reg ) int-regs return-regs at first ;
+
: (sse-version) ( -- n )
int { } cdecl [
"sse-42" define-label
"sse-1" define-label
"end" define-label
- int-regs return-reg 1 MOV
+ return-reg 1 MOV
CPUID
EDX 25 BT
"sse-1" get JB
- int-regs return-reg 0 MOV
+ return-reg 0 MOV
"end" get JMP
"sse-42" resolve-label
- int-regs return-reg 42 MOV
+ return-reg 42 MOV
"end" get JMP
"sse-41" resolve-label
- int-regs return-reg 41 MOV
+ return-reg 41 MOV
"end" get JMP
"ssse-3" resolve-label
- int-regs return-reg 33 MOV
+ return-reg 33 MOV
"end" get JMP
"sse-3" resolve-label
- int-regs return-reg 30 MOV
+ return-reg 30 MOV
"end" get JMP
"sse-2" resolve-label
- int-regs return-reg 20 MOV
+ return-reg 20 MOV
"end" get JMP
"sse-1" resolve-label
- int-regs return-reg 10 MOV
+ return-reg 10 MOV
"end" resolve-label
] alien-assembly ;
stack-frame get extra-stack-space +
reserved-stack-space + ;
-: special@ ( n -- op ) special-offset stack@ ;
-
-: spill@ ( n -- op ) spill-offset special@ ;
-
-: param@ ( n -- op ) reserved-stack-space + stack@ ;
+: spill@ ( n -- op ) spill-offset special-offset stack@ ;
: gc-root-offsets ( seq -- seq' )
[ n>> spill-offset special-offset cell + ] map f like ;
3 cells +
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 )
M: x86 complex-addressing? t ;
[ \ f type-number MOV ]
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: rs-reg cpu ( -- reg )
M:: x86 %reload ( dst rep src -- )
dst src rep %copy ;
-M:: x86 %store-reg-param ( src reg rep -- )
- reg src rep %copy ;
-
M:: x86 %store-stack-param ( src n rep -- )
- n param@ src rep %copy ;
+ n reserved-stack-space + stack@ src rep %copy ;
+
+: %load-return ( dst rep -- )
+ [ reg-class-of return-regs at first ] keep %load-reg-param ;
+
+: %store-return ( dst rep -- )
+ [ 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 + [+] ;
-HOOK: struct-return@ cpu ( n -- operand )
+M:: x86 %load-stack-param ( dst n rep -- )
+ dst n next-stack@ rep %copy ;
-M: x86 %prepare-struct-area ( dst -- )
- f struct-return@ LEA ;
+M: x86 %prepare-struct-caller ( dst -- )
+ return-offset special-offset stack@ LEA ;
M: x86 %alien-indirect ( src -- )
?spill-slot CALL ;
M: x86 immediate-bitwise? ( n -- ? )
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-log2
-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 ;
IN: math.floats.env.x86.64
M: x86.64 get-sse-env
void { void* } cdecl [
- int-regs cdecl param-regs first [] STMXCSR
+ param-reg-0 [] STMXCSR
] alien-assembly ;
M: x86.64 set-sse-env
void { void* } cdecl [
- int-regs cdecl param-regs first [] LDMXCSR
+ param-reg-0 [] LDMXCSR
] alien-assembly ;
M: x86.64 get-x87-env
void { void* } cdecl [
- int-regs cdecl param-regs first [] FNSTSW
- int-regs cdecl param-regs first 2 [+] FNSTCW
+ param-reg-0 [] FNSTSW
+ param-reg-0 2 [+] FNSTCW
] alien-assembly ;
M: x86.64 set-x87-env
void { void* } cdecl [
FNCLEX
- int-regs cdecl param-regs first 2 [+] FLDCW
+ param-reg-0 2 [+] FLDCW
] alien-assembly ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors combinators math namespaces
init sets words assocs alien.libraries alien alien.private
-alien.c-types fry stack-checker.backend
+alien.c-types fry quotations stack-checker.backend
stack-checker.errors stack-checker.visitor
-stack-checker.dependencies ;
+stack-checker.dependencies compiler.utilities ;
IN: stack-checker.alien
TUPLE: alien-node-params return parameters abi in-d out-d ;
: callback-bottom ( params -- )
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 ( -- )
alien-callback-params new
pop-quot
pop-params
pop-return
"( callback )" <uninterned-word> >>xt
+ dup wrap-callback-quot >>quot
dup callback-bottom
#alien-callback, ;
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);
-}
-
}
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 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);
}
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()
{
cell size = unbox_array_size();
return data;
}
+VM_C_API cell allot_byte_array(cell size, factor_vm *parent);
+
}
void primitive_dlclose();
void primitive_dll_validp();
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
void primitive_jit_compile();
projects / factor.git / commitdiff