! 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 fry make sequences locals alien alien.private\r
-alien.strings alien.c-types alien.libraries classes.struct\r
-namespaces kernel strings libc quotations cpu.architecture\r
-compiler.alien compiler.utilities compiler.tree compiler.cfg\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\r
+cpu.architecture 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
\r
: (objects>registers) ( vregs -- )\r
! Place instructions in reverse order, so that the\r
- ! ##store-stack-param instructions come first. This is\r
- ! because they are not clobber-insns and so we avoid some\r
- ! spills that way.\r
+ ! ##store-stack-param instructions come 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
if\r
] map reverse % ;\r
\r
-: objects>registers ( params -- )\r
- #! Generate code for unboxing a list of C types, then\r
- #! generate code for moving these parameters to registers on\r
- #! architectures where parameters are passed in registers.\r
+: objects>registers ( params -- stack-size )\r
[ abi>> ] [ parameters>> ] [ return>> ] tri\r
'[ \r
_ unbox-parameters\r
_ prepare-struct-area\r
(objects>registers)\r
+ stack-params get\r
] with-param-regs ;\r
\r
GENERIC: box-return ( c-type -- dst )\r
M: long-long-type box-return\r
[ f ] dip boxer>> ^^box-long-long ;\r
\r
-: if-small-struct ( c-type true false -- ? )\r
- [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline\r
-\r
M: struct-c-type box-return\r
- [ ^^box-small-struct ] [ ^^box-large-struct ] if-small-struct ;\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
[ library>> load-library ]\r
bi 2dup check-dlsym ;\r
\r
-: return-size ( ctype -- n )\r
+: return-size ( c-type -- n )\r
#! Amount of space we reserve for a return value.\r
{\r
- { [ dup c-struct? not ] [ drop 0 ] }\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
\r
-: <alien-stack-frame> ( params -- stack-frame )\r
- stack-frame new\r
- swap\r
- [ return>> return-size >>return ]\r
- [ alien-parameters [ stack-size ] map-sum >>params ] bi\r
- t >>calls-vm? ;\r
-\r
: alien-node-height ( params -- )\r
[ out-d>> length ] [ in-d>> length ] bi - adjust-d ;\r
\r
-: emit-alien-node ( node quot -- )\r
+: emit-alien-block ( node quot: ( params -- ) -- )\r
'[\r
make-kill-block\r
params>>\r
- [ <alien-stack-frame> ##stack-frame ]\r
- _\r
- [ alien-node-height ]\r
- tri\r
+ _ [ alien-node-height ] bi\r
] emit-trivial-block ; inline\r
\r
+: <alien-stack-frame> ( stack-size return -- stack-frame )\r
+ stack-frame new\r
+ swap return-size >>return\r
+ swap >>params\r
+ t >>calls-vm? ;\r
+\r
+: emit-stack-frame ( stack-size params -- )\r
+ return>>\r
+ [ stack-cleanup ##cleanup ]\r
+ [ <alien-stack-frame> ##stack-frame ] bi ;\r
+\r
M: #alien-invoke emit-node\r
[\r
{\r
[ objects>registers ]\r
[ alien-invoke-dlsym ##alien-invoke ]\r
- [ stack-cleanup ##cleanup ]\r
+ [ emit-stack-frame ]\r
[ box-return* ]\r
} cleave\r
- ] emit-alien-node ;\r
+ ] emit-alien-block ;\r
\r
-M: #alien-indirect emit-node\r
- [\r
- D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr\r
+M:: #alien-indirect emit-node ( node -- )\r
+ node [\r
+ D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src\r
{\r
- [ drop objects>registers ]\r
- [ nip ##alien-indirect ]\r
- [ drop stack-cleanup ##cleanup ]\r
- [ drop box-return* ]\r
- } 2cleave\r
- ] emit-alien-node ;\r
+ [ objects>registers ]\r
+ [ drop src ##alien-indirect ]\r
+ [ emit-stack-frame ]\r
+ [ box-return* ]\r
+ } cleave\r
+ ] emit-alien-block ;\r
\r
M: #alien-assembly emit-node\r
[\r
- [ objects>registers ]\r
- [ quot>> ##alien-assembly ]\r
- [ box-return* ]\r
- tri\r
- ] emit-alien-node ;\r
+ {\r
+ [ objects>registers ]\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
: prepare-parameters ( parameters -- offsets types indices )\r
[ length iota <reversed> ] [ parameter-offsets ] [ ] tri ;\r
\r
+: alien-parameters ( params -- seq )\r
+ [ parameters>> ] [ return>> large-struct? ] bi\r
+ [ struct-return-on-stack? (stack-value) void* ? prefix ] when ;\r
+\r
: box-parameters ( params -- )\r
alien-parameters\r
[ length ##inc-d ]\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
+\r
M: #alien-callback emit-node\r
dup params>> xt>> dup\r
[\r
##prologue\r
[\r
- [ registers>objects ]\r
- [ wrap-callback-quot ##alien-callback ]\r
- [\r
- return>> {\r
- { [ dup void eq? ] [ 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
- ] tri\r
- ] emit-alien-node\r
+ {\r
+ [ registers>objects ]\r
+ [ emit-callback-stack-frame ]\r
+ [ wrap-callback-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
+ ]\r
+ } cleave\r
+ ] emit-alien-block\r
##epilogue\r
##return\r
] with-cfg-builder ;\r
projects / factor.git / commitdiff