compiler.alien compiler.utilities compiler.tree compiler.cfg\r
compiler.cfg.builder compiler.cfg.builder.blocks\r
compiler.cfg.instructions compiler.cfg.stack-frame\r
-compiler.cfg.stacks ;\r
+compiler.cfg.stacks compiler.cfg.registers\r
+compiler.cfg.hats ;\r
FROM: compiler.errors => no-such-symbol no-such-library ;\r
IN: compiler.cfg.builder.alien\r
\r
[ [ parameter-offsets ] keep ] dip 2reverse-each ; inline\r
\r
: prepare-unbox-parameters ( parameters -- offsets types indices )\r
- [ parameter-offsets ] [ ] [ length iota <reversed> ] tri ;\r
+ [ length iota <reversed> ] [ parameter-offsets ] [ ] tri ;\r
\r
-GENERIC: unbox-parameter ( n c-type -- )\r
+GENERIC: unbox-parameter ( src n c-type -- )\r
\r
M: c-type unbox-parameter\r
[ rep>> ] [ unboxer>> ] bi ##unbox ;\r
parameters>> swap\r
'[\r
prepare-unbox-parameters\r
- [ ##pop-stack [ _ + ] dip base-type unbox-parameter ] 3each\r
+ [\r
+ [ <ds-loc> ^^peek ] [ _ + ] [ base-type ] tri*\r
+ unbox-parameter\r
+ ] 3each\r
]\r
[ length neg ##inc-d ]\r
bi ;\r
\ ##load-param-reg move-parameters\r
] with-param-regs ;\r
\r
-GENERIC: box-return ( c-type -- )\r
+GENERIC: box-return ( c-type -- dst )\r
\r
M: c-type box-return\r
- [ f ] dip [ rep>> ] [ boxer>> ] bi ##box ;\r
+ [ f ] dip [ rep>> ] [ boxer>> ] bi ^^box ;\r
\r
M: long-long-type box-return\r
- [ f ] dip boxer>> ##box-long-long ;\r
+ [ f ] dip boxer>> ^^box-long-long ;\r
\r
M: struct-c-type box-return\r
- [ ##box-small-struct ] [ ##box-large-struct ] if-small-struct ;\r
+ [ ^^box-small-struct ] [ ^^box-large-struct ] if-small-struct ;\r
\r
: box-return* ( node -- )\r
- return>> [ ] [ base-type box-return ##push-stack ] if-void ;\r
+ return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;\r
\r
GENERIC# dlsym-valid? 1 ( symbols dll -- ? )\r
\r
\r
M: #alien-indirect emit-node\r
[\r
- ! Save alien at top of stack to temporary storage\r
- ##prepare-alien-indirect\r
- ! Unbox parameters\r
- dup objects>registers\r
- ! Call alien in temporary storage\r
- ##alien-indirect\r
- ! Box return value\r
- dup ##cleanup\r
- box-return*\r
+ D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr\r
+ {\r
+ [ drop objects>registers ]\r
+ [ nip ##alien-indirect ]\r
+ [ drop ##cleanup ]\r
+ [ drop box-return* ]\r
+ } 2cleave\r
] emit-alien-node ;\r
\r
M: #alien-assembly emit-node\r
[\r
- ! Unbox parameters\r
- dup objects>registers\r
- ! Generate assembly\r
- dup quot>> ##alien-assembly\r
- ! Box return value\r
- box-return*\r
+ [ objects>registers ]\r
+ [ quot>> ##alien-assembly ]\r
+ [ box-return* ]\r
+ tri\r
] emit-alien-node ;\r
\r
-GENERIC: box-parameter ( n c-type -- )\r
+GENERIC: box-parameter ( n c-type -- dst )\r
\r
M: c-type box-parameter\r
- [ rep>> ] [ boxer>> ] bi ##box ;\r
+ [ rep>> ] [ boxer>> ] bi ^^box ;\r
\r
M: long-long-type box-parameter\r
- boxer>> ##box-long-long ;\r
+ boxer>> ^^box-long-long ;\r
\r
M: struct-c-type box-parameter\r
- [ ##box-large-struct ] [ base-type box-parameter ] if-value-struct ;\r
+ [ ^^box-large-struct ] [ base-type box-parameter ] if-value-struct ;\r
\r
: box-parameters ( params -- )\r
alien-parameters\r
- [ base-type box-parameter ##push-context-stack ] each-parameter ;\r
+ [ base-type box-parameter next-vreg ##push-context-stack ] each-parameter ;\r
\r
: registers>objects ( node -- )\r
! Generate code for boxing input parameters in a callback.\r
'[ _ _ do-callback ]\r
>quotation ;\r
\r
-GENERIC: unbox-return ( c-type -- )\r
+GENERIC: unbox-return ( src c-type -- )\r
\r
M: c-type unbox-return\r
[ f ] dip [ rep>> ] [ unboxer>> ] bi ##unbox ;\r
[ wrap-callback-quot ##alien-callback ]\r
[\r
alien-return [ ##end-callback ] [\r
- ##pop-context-stack\r
- ##to-nv\r
+ [ ^^pop-context-stack ] dip\r
##end-callback\r
- ##from-nv\r
base-type unbox-return\r
] if-void\r
] tri\r
literal: stack-frame ;
INSN: ##box
+def: dst/tagged-rep
literal: n rep boxer ;
INSN: ##box-long-long
+def: dst/tagged-rep
literal: n boxer ;
INSN: ##box-small-struct
+def: dst/tagged-rep
literal: c-type ;
INSN: ##box-large-struct
+def: dst/tagged-rep
literal: n c-type ;
INSN: ##unbox
+use: src/tagged-rep
literal: n rep unboxer ;
INSN: ##unbox-long-long
+use: src/tagged-rep
literal: n unboxer ;
INSN: ##unbox-large-struct
+use: src/tagged-rep
literal: n c-type ;
INSN: ##unbox-small-struct
+use: src/tagged-rep
literal: c-type ;
-INSN: ##pop-stack
-literal: n ;
-
-INSN: ##pop-context-stack ;
+INSN: ##pop-context-stack
+def: dst/tagged-rep
+temp: temp/int-rep ;
INSN: ##prepare-box-struct ;
INSN: ##load-param-reg
literal: offset reg rep ;
-INSN: ##push-stack ;
-
INSN: ##alien-invoke
literal: symbols dll ;
INSN: ##cleanup
literal: params ;
-INSN: ##prepare-alien-indirect ;
-
-INSN: ##alien-indirect ;
+INSN: ##alien-indirect
+use: src/int-rep ;
INSN: ##alien-assembly
literal: quot ;
-INSN: ##push-context-stack ;
+INSN: ##push-context-stack
+use: src/tagged-rep
+temp: temp/int-rep ;
INSN: ##save-param-reg
literal: offset reg rep ;
INSN: ##end-callback ;
-INSN: ##to-nv ;
-
-INSN: ##from-nv ;
-
! Control flow
INSN: ##phi
def: dst
UNION: clobber-insn
##call-gc
##unary-float-function
-##binary-float-function ;
+##binary-float-function
+##box
+##box-long-long
+##box-small-struct
+##box-large-struct
+##unbox
+##unbox-long-long
+##unbox-large-struct
+##unbox-small-struct
+##prepare-box-struct
+##load-param-reg
+##alien-invoke
+##alien-indirect
+##alien-assembly
+##save-param-reg
+##begin-callback
+##end-callback ;
! Instructions that have complex expansions and require that the
! output registers are not equal to any of the input registers
CODEGEN: ##unbox-long-long %unbox-long-long
CODEGEN: ##unbox-large-struct %unbox-large-struct
CODEGEN: ##unbox-small-struct %unbox-small-struct
-CODEGEN: ##pop-stack %pop-stack
CODEGEN: ##pop-context-stack %pop-context-stack
CODEGEN: ##prepare-box-struct %prepare-box-struct
CODEGEN: ##load-param-reg %load-param-reg
-CODEGEN: ##push-stack %push-stack
CODEGEN: ##alien-invoke %alien-invoke
CODEGEN: ##cleanup %cleanup
-CODEGEN: ##prepare-alien-indirect %prepare-alien-indirect
CODEGEN: ##alien-indirect %alien-indirect
CODEGEN: ##push-context-stack %push-context-stack
CODEGEN: ##save-param-reg %save-param-reg
CODEGEN: ##begin-callback %begin-callback
CODEGEN: ##alien-callback %alien-callback
CODEGEN: ##end-callback %end-callback
-CODEGEN: ##to-nv %to-nv
-CODEGEN: ##from-nv %from-nv
M: ##alien-assembly generate-insn quot>> call( -- ) ;
{ 1 1 } [ indirect-test-1 ] must-infer-as
-[ B{ } indirect-test-1 ] [ { "kernel-error" 3 6 B{ } } = ] must-fail-with
-
[ 3 ] [ &: ffi_test_1 indirect-test-1 ] unit-test
: indirect-test-1' ( ptr -- )
! If t, all int parameters are shadowed by dummy FP parameters
HOOK: dummy-fp-params? cpu ( -- ? )
-! Load a value (from the data stack in the ds register).
-! The value is then passed as a parameter to a VM to_*() function
-HOOK: %pop-stack cpu ( n -- )
-
! Store a value (to the data stack in the VM's current context)
! The value is passed to a VM to_*() function -- used for
! callback returns
-HOOK: %pop-context-stack cpu ( -- )
-
-! Store a value (to the data stack in the ds register).
-! The value was returned from a VM from_*() function
-HOOK: %push-stack cpu ( -- )
+HOOK: %pop-context-stack cpu ( dst temp -- )
! Store a value (to the data stack in the VM's current context)
! The value is returned from a VM from_*() function -- used for
! callback parameters
-HOOK: %push-context-stack cpu ( -- )
+HOOK: %push-context-stack cpu ( src temp -- )
! Call a function to convert a tagged pointer returned by
! %pop-stack or %pop-context-stack into a value that can be
! passed to a C function, or returned from a callback
-HOOK: %unbox cpu ( n rep func -- )
+HOOK: %unbox cpu ( src n rep func -- )
-HOOK: %unbox-long-long cpu ( n func -- )
+HOOK: %unbox-long-long cpu ( src n func -- )
-HOOK: %unbox-small-struct cpu ( c-type -- )
+HOOK: %unbox-small-struct cpu ( src c-type -- )
-HOOK: %unbox-large-struct cpu ( n c-type -- )
+HOOK: %unbox-large-struct cpu ( src n c-type -- )
! 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 by %push-stack or
! %push-context-stack
-HOOK: %box cpu ( n rep func -- )
+HOOK: %box cpu ( dst n rep func -- )
-HOOK: %box-long-long cpu ( n func -- )
+HOOK: %box-long-long cpu ( dst n func -- )
HOOK: %prepare-box-struct cpu ( -- )
-HOOK: %box-small-struct cpu ( c-type -- )
+HOOK: %box-small-struct cpu ( dst c-type -- )
-HOOK: %box-large-struct cpu ( n c-type -- )
+HOOK: %box-large-struct cpu ( dst n c-type -- )
HOOK: %save-param-reg cpu ( stack reg rep -- )
HOOK: %save-context cpu ( temp1 temp2 -- )
-HOOK: %prepare-var-args cpu ( -- )
-
-M: object %prepare-var-args ;
-
HOOK: %alien-invoke cpu ( function library -- )
HOOK: %cleanup cpu ( params -- )
M: object %cleanup ( params -- ) drop ;
-HOOK: %prepare-alien-indirect cpu ( -- )
-
-HOOK: %alien-indirect cpu ( -- )
+HOOK: %alien-indirect cpu ( src -- )
HOOK: %begin-callback cpu ( -- )
HOOK: %end-callback cpu ( -- )
-HOOK: %to-nv cpu ( -- )
-
-HOOK: %from-nv cpu ( -- )
-
HOOK: stack-cleanup cpu ( params -- n )
M: object stack-cleanup drop 0 ;
#! parameter being passed to a callback from C.
over [ [ local@ ] dip load-return-reg ] [ 2drop ] if ;
-M:: x86.32 %box ( n rep func -- )
+M:: x86.32 %box ( dst n rep func -- )
n rep (%box)
rep rep-size save-vm-ptr
0 stack@ rep store-return-reg
- func f %alien-invoke ;
+ func f %alien-invoke
+ dst EAX tagged-rep %copy ;
: (%box-long-long) ( n -- )
[
EAX swap cell - next-stack@ MOV
] when* ;
-M: x86.32 %box-long-long ( n func -- )
- [ (%box-long-long) ] dip
+M:: x86.32 %box-long-long ( dst n func -- )
+ n (%box-long-long)
8 save-vm-ptr
4 stack@ EDX MOV
0 stack@ EAX MOV
- f %alien-invoke ;
+ func f %alien-invoke
+ dst EAX tagged-rep %copy ;
-M:: x86.32 %box-large-struct ( n c-type -- )
+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 ;
+ "from_value_struct" f %alien-invoke
+ dst EAX tagged-rep %copy ;
M: x86.32 %prepare-box-struct ( -- )
! Compute target address for value struct return
! Store it as the first parameter
0 local@ EAX MOV ;
-M: x86.32 %box-small-struct ( c-type -- )
+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@ swap heap-size MOV
4 stack@ EDX MOV
0 stack@ EAX MOV
- "from_small_struct" f %alien-invoke ;
-
-M: x86.32 %pop-stack ( n -- )
- EAX swap ds-reg reg-stack MOV ;
+ "from_small_struct" f %alien-invoke
+ dst EAX tagged-rep %copy ;
-M: x86.32 %pop-context-stack ( -- )
- temp-reg %context
- EAX temp-reg "datastack" context-field-offset [+] MOV
- EAX EAX [] MOV
- temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
+M:: x86.32 %pop-context-stack ( dst temp -- )
+ temp %context
+ dst temp "datastack" context-field-offset [+] MOV
+ dst dst [] MOV
+ temp "datastack" context-field-offset [+] bootstrap-cell SUB ;
-: call-unbox-func ( func -- )
+: call-unbox-func ( src func -- )
+ EAX src tagged-rep %copy
4 save-vm-ptr
0 stack@ EAX MOV
f %alien-invoke ;
-M: x86.32 %unbox ( n rep func -- )
- #! The value being unboxed must already be in EAX.
- #! If n is f, we're unboxing a return value about to be
- #! returned by the callback. Otherwise, we're unboxing
- #! a parameter to a C function about to be called.
- call-unbox-func
+M:: x86.32 %unbox ( src n rep func -- )
+ ! If n is f, we're unboxing a return value about to be
+ ! returned by the callback. Otherwise, we're unboxing
+ ! a parameter to a C function about to be called.
+ src func call-unbox-func
! Store the return value on the C stack
- over [ [ local@ ] dip store-return-reg ] [ 2drop ] if ;
+ n [ n local@ rep store-return-reg ] when ;
-M: x86.32 %unbox-long-long ( n func -- )
+M:: x86.32 %unbox-long-long ( src n func -- )
call-unbox-func
! Store the return value on the C stack
[
[ 4 + local@ EDX MOV ] bi
] when* ;
-: %unbox-struct-1 ( -- )
- #! Alien must be in EAX.
- 4 save-vm-ptr
- 0 stack@ EAX MOV
- "alien_offset" f %alien-invoke
- ! Load first cell
- EAX EAX [] MOV ;
-
-: %unbox-struct-2 ( -- )
- #! Alien must be in EAX.
- 4 save-vm-ptr
- 0 stack@ EAX MOV
- "alien_offset" f %alien-invoke
- ! Load second cell
- EDX EAX 4 [+] MOV
- ! Load first cell
- EAX EAX [] MOV ;
-
-M: x86 %unbox-small-struct ( size -- )
- #! Alien must be in EAX.
- heap-size cell align cell /i {
- { 1 [ %unbox-struct-1 ] }
- { 2 [ %unbox-struct-2 ] }
- } case ;
+M: x86 %unbox-small-struct ( src size -- )
+ [ "alien_offset" call-unbox-func ]
+ [
+ heap-size 4 > [ EDX EAX 4 [+] MOV ] when
+ EAX EAX [] MOV
+ ] bi* ;
-M:: x86.32 %unbox-large-struct ( n c-type -- )
- ! Alien must be in EAX.
+M:: x86.32 %unbox-large-struct ( src n c-type -- )
+ EAX src tagged-rep %copy
! Compute destination address
EDX n local@ LEA
12 save-vm-ptr
0 stack@ EAX MOV
"to_value_struct" f %alien-invoke ;
-M: x86.32 %prepare-alien-indirect ( -- )
- EAX ds-reg [] MOV
- ds-reg 4 SUB
- 4 save-vm-ptr
- 0 stack@ EAX MOV
- "pinned_alien_offset" f %alien-invoke
- EBP EAX MOV ;
-
-M: x86.32 %alien-indirect ( -- )
- EBP CALL ;
+M: x86.32 %alien-indirect ( src -- )
+ ?spill-slot CALL ;
M: x86.32 %begin-callback ( -- )
0 save-vm-ptr
0 save-vm-ptr
"end_callback" f %alien-invoke ;
-M: x86.32 %to-nv ( -- ) 4 stack@ EAX MOV ;
-
-M: x86.32 %from-nv ( -- ) EAX 4 stack@ MOV ;
-
GENERIC: float-function-param ( stack-slot dst src -- )
M:: spill-slot float-function-param ( stack-slot dst src -- )
call
] with-scope ; inline
-M: x86.64 %pop-stack ( n -- )
- param-reg-0 swap ds-reg reg-stack MOV ;
-
-M: x86.64 %pop-context-stack ( -- )
- temp-reg %context
- param-reg-0 temp-reg "datastack" context-field-offset [+] MOV
- param-reg-0 param-reg-0 [] MOV
- temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
-
-M:: x86.64 %unbox ( n rep func -- )
+M:: x86.64 %pop-context-stack ( dst temp -- )
+ temp %context
+ dst temp "datastack" context-field-offset [+] MOV
+ dst dst [] MOV
+ temp "datastack" context-field-offset [+] bootstrap-cell SUB ;
+
+M:: x86.64 %unbox ( src n rep func -- )
+ param-reg-0 src tagged-rep %copy
param-reg-1 %mov-vm-ptr
! Call the unboxer
func f %alien-invoke
n [ n rep reg-class-of return-reg rep %save-param-reg ] when ;
: %unbox-struct-field ( rep i -- )
- ! Alien must be in param-reg-0.
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 %unbox-small-struct ( c-type -- )
- ! Alien must be in param-reg-0.
+M:: x86.64 %unbox-small-struct ( src c-type -- )
+ param-reg-0 src tagged-rep %copy
param-reg-1 %mov-vm-ptr
"alien_offset" f %alien-invoke
! Move alien_offset() return value to R11 so that we don't
! clobber it.
R11 RAX MOV
[
- flatten-struct-type [ %unbox-struct-field ] each-index
+ c-type flatten-struct-type
+ [ %unbox-struct-field ] each-index
] with-return-regs ;
-M:: x86.64 %unbox-large-struct ( n c-type -- )
- ! Source is in param-reg-0
+M:: x86.64 %unbox-large-struct ( src n c-type -- )
+ param-reg-0 src tagged-rep %copy
! Load destination address into param-reg-1
param-reg-1 n param@ LEA
! Load structure size into param-reg-2
[ ]
tri %copy ;
-M:: x86.64 %box ( n rep func -- )
+M:: x86.64 %box ( dst n rep func -- )
n [
n
0 rep reg-class-of cdecl param-reg
rep load-return-value
] if
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 ;
: box-struct-field@ ( i -- operand ) 1 + cells param@ ;
{ float-regs [ float-regs get pop MOVSD ] }
} case ;
-M: x86.64 %box-small-struct ( c-type -- )
+M:: x86.64 %box-small-struct ( dst c-type -- )
#! Box a <= 16-byte struct.
[
- [ flatten-struct-type [ %box-struct-field ] each-index ]
- [ param-reg-2 swap heap-size MOV ] bi
+ c-type flatten-struct-type [ %box-struct-field ] each-index
+ param-reg-2 c-type heap-size MOV
param-reg-0 0 box-struct-field@ MOV
param-reg-1 1 box-struct-field@ MOV
param-reg-3 %mov-vm-ptr
"from_small_struct" f %alien-invoke
+ dst RAX tagged-rep %copy
] with-return-regs ;
: struct-return@ ( n -- operand )
[ stack-frame get params>> ] unless* param@ ;
-M: x86.64 %box-large-struct ( n c-type -- )
+M:: x86.64 %box-large-struct ( dst n c-type -- )
! Struct size is parameter 2
- param-reg-1 swap heap-size MOV
+ param-reg-1 c-type heap-size MOV
! Compute destination address
- param-reg-0 swap struct-return@ LEA
+ 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 ;
+ "from_value_struct" f %alien-invoke
+ dst RAX tagged-rep %copy ;
M: x86.64 %prepare-box-struct ( -- )
! Compute target address for value struct return
! Store it as the first parameter
0 param@ RAX MOV ;
-M: x86.64 %prepare-var-args RAX RAX XOR ;
-
M: x86.64 %alien-invoke
R11 0 MOV
rc-absolute-cell rel-dlsym
R11 CALL ;
-M: x86.64 %prepare-alien-indirect ( -- )
- param-reg-0 ds-reg [] MOV
- ds-reg 8 SUB
- param-reg-1 %mov-vm-ptr
- "pinned_alien_offset" f %alien-invoke
- nv-reg RAX MOV ;
-
-M: x86.64 %alien-indirect ( -- )
- nv-reg CALL ;
+M: x86.64 %alien-indirect ( src -- )
+ ?spill-slot CALL ;
M: x86.64 %begin-callback ( -- )
param-reg-0 %mov-vm-ptr
param-reg-0 %mov-vm-ptr
"end_callback" f %alien-invoke ;
-M: x86.64 %to-nv ( -- ) nv-reg param-reg-0 MOV ;
-
-M: x86.64 %from-nv ( -- ) param-reg-0 nv-reg MOV ;
-
: float-function-param ( i src -- )
[ float-regs cdecl param-regs nth ] dip double-rep %copy ;
M: float-rep copy-memory* drop MOVSS ;
M: double-rep copy-memory* drop MOVSD ;
+: ?spill-slot ( obj -- obj ) dup spill-slot? [ n>> spill@ ] when ;
+
M: x86 %copy ( dst src rep -- )
2over eq? [ 3drop ] [
- [ [ dup spill-slot? [ n>> spill@ ] when ] bi@ ] dip
+ [ [ ?spill-slot ] bi@ ] dip
2over [ register? ] both? [ copy-register* ] [ copy-memory* ] if
] if ;
M: x86 %alien-global ( dst symbol library -- )
[ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;
-M: x86 %push-stack ( -- )
- ds-reg cell ADD
- ds-reg [] int-regs return-reg MOV ;
-
-M: x86 %push-context-stack ( -- )
- temp-reg %context
- temp-reg "datastack" context-field-offset [+] bootstrap-cell ADD
- temp-reg temp-reg "datastack" context-field-offset [+] MOV
- temp-reg [] int-regs return-reg MOV ;
+M:: x86 %push-context-stack ( src temp -- )
+ temp %context
+ temp "datastack" context-field-offset [+] bootstrap-cell ADD
+ temp temp "datastack" context-field-offset [+] MOV
+ temp [] src MOV ;
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
: param-prep-quot ( params -- quot )
parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
-: infer-params ( params -- )
- param-prep-quot infer-quot-here ;
-
: alien-stack ( params extra -- )
over parameters>> length + consume-d >>in-d
dup return>> void? 0 1 ? produce-d >>out-d
! Set ABI
dup library>> library-abi >>abi
! Quotation which coerces parameters to required types
- dup infer-params
+ dup param-prep-quot infer-quot-here
! Magic #: consume exactly the number of inputs
dup 0 alien-stack
! Add node to IR
pop-abi
pop-params
pop-return
- ! Quotation which coerces parameters to required types
- 1 infer->r
- dup infer-params
- 1 infer-r>
+ ! Coerce parameters to required types
+ dup param-prep-quot '[ _ [ >c-ptr ] bi* ] infer-quot-here
! Magic #: consume the function pointer, too
dup 1 alien-stack
! Add node to IR
pop-params
pop-return
! Quotation which coerces parameters to required types
- dup infer-params
+ dup param-prep-quot infer-quot-here
! Magic #: consume exactly the number of inputs
dup 0 alien-stack
! Add node to IR
projects / factor.git / commitdiff