diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor index 8bdf4ccb46..7ec1bee1a3 100644 --- a/basis/compiler/cfg/builder/alien/alien.factor +++ b/basis/compiler/cfg/builder/alien/alien.factor @@ -7,7 +7,8 @@ namespaces kernel strings libc quotations cpu.architecture compiler.alien compiler.utilities compiler.tree compiler.cfg compiler.cfg.builder compiler.cfg.builder.blocks compiler.cfg.instructions compiler.cfg.stack-frame -compiler.cfg.stacks ; +compiler.cfg.stacks compiler.cfg.registers +compiler.cfg.hats ; FROM: compiler.errors => no-such-symbol no-such-library ; IN: compiler.cfg.builder.alien @@ -78,9 +79,9 @@ M: reg-class reg-class-full? [ [ parameter-offsets ] keep ] dip 2reverse-each ; inline : prepare-unbox-parameters ( parameters -- offsets types indices ) - [ parameter-offsets ] [ ] [ length iota ] tri ; + [ length iota ] [ parameter-offsets ] [ ] tri ; -GENERIC: unbox-parameter ( n c-type -- ) +GENERIC: unbox-parameter ( src n c-type -- ) M: c-type unbox-parameter [ rep>> ] [ unboxer>> ] bi ##unbox ; @@ -95,7 +96,10 @@ M: struct-c-type unbox-parameter parameters>> swap '[ prepare-unbox-parameters - [ ##pop-stack [ _ + ] dip base-type unbox-parameter ] 3each + [ + [ ^^peek ] [ _ + ] [ base-type ] tri* + unbox-parameter + ] 3each ] [ length neg ##inc-d ] bi ; @@ -118,19 +122,19 @@ M: struct-c-type unbox-parameter \ ##load-param-reg move-parameters ] with-param-regs ; -GENERIC: box-return ( c-type -- ) +GENERIC: box-return ( c-type -- dst ) M: c-type box-return - [ f ] dip [ rep>> ] [ boxer>> ] bi ##box ; + [ f ] dip [ rep>> ] [ boxer>> ] bi ^^box ; M: long-long-type box-return - [ f ] dip boxer>> ##box-long-long ; + [ f ] dip boxer>> ^^box-long-long ; M: struct-c-type box-return - [ ##box-small-struct ] [ ##box-large-struct ] if-small-struct ; + [ ^^box-small-struct ] [ ^^box-large-struct ] if-small-struct ; : box-return* ( node -- ) - return>> [ ] [ base-type box-return ##push-stack ] if-void ; + return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ; GENERIC# dlsym-valid? 1 ( symbols dll -- ? ) @@ -200,41 +204,37 @@ M: #alien-invoke emit-node M: #alien-indirect emit-node [ - ! Save alien at top of stack to temporary storage - ##prepare-alien-indirect - ! Unbox parameters - dup objects>registers - ! Call alien in temporary storage - ##alien-indirect - ! Box return value - dup ##cleanup - box-return* + D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr + { + [ drop objects>registers ] + [ nip ##alien-indirect ] + [ drop ##cleanup ] + [ drop box-return* ] + } 2cleave ] emit-alien-node ; M: #alien-assembly emit-node [ - ! Unbox parameters - dup objects>registers - ! Generate assembly - dup quot>> ##alien-assembly - ! Box return value - box-return* + [ objects>registers ] + [ quot>> ##alien-assembly ] + [ box-return* ] + tri ] emit-alien-node ; -GENERIC: box-parameter ( n c-type -- ) +GENERIC: box-parameter ( n c-type -- dst ) M: c-type box-parameter - [ rep>> ] [ boxer>> ] bi ##box ; + [ rep>> ] [ boxer>> ] bi ^^box ; M: long-long-type box-parameter - boxer>> ##box-long-long ; + boxer>> ^^box-long-long ; M: struct-c-type box-parameter - [ ##box-large-struct ] [ base-type box-parameter ] if-value-struct ; + [ ^^box-large-struct ] [ base-type box-parameter ] if-value-struct ; : box-parameters ( params -- ) alien-parameters - [ base-type box-parameter ##push-context-stack ] each-parameter ; + [ base-type box-parameter next-vreg ##push-context-stack ] each-parameter ; : registers>objects ( node -- ) ! Generate code for boxing input parameters in a callback. @@ -260,7 +260,7 @@ M: struct-c-type box-parameter '[ _ _ do-callback ] >quotation ; -GENERIC: unbox-return ( c-type -- ) +GENERIC: unbox-return ( src c-type -- ) M: c-type unbox-return [ f ] dip [ rep>> ] [ unboxer>> ] bi ##unbox ; @@ -280,10 +280,8 @@ M: #alien-callback emit-node [ wrap-callback-quot ##alien-callback ] [ alien-return [ ##end-callback ] [ - ##pop-context-stack - ##to-nv + [ ^^pop-context-stack ] dip ##end-callback - ##from-nv base-type unbox-return ] if-void ] tri diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 87055eb550..14681b4777 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -613,55 +613,61 @@ INSN: ##stack-frame 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 ; @@ -673,10 +679,6 @@ literal: quot ; INSN: ##end-callback ; -INSN: ##to-nv ; - -INSN: ##from-nv ; - ! Control flow INSN: ##phi def: dst @@ -812,7 +814,23 @@ UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ; 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 diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 5b2c52ce28..a106e55e81 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -283,21 +283,16 @@ CODEGEN: ##unbox %unbox 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( -- ) ; diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index bd770eb8de..b8c48abfc3 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -99,8 +99,6 @@ FUNCTION: TINY ffi_test_17 int x ; { 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 -- ) diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 6657fd8c85..337fa04977 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -553,48 +553,40 @@ HOOK: dummy-int-params? cpu ( -- ? ) ! 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 -- ) @@ -604,19 +596,13 @@ HOOK: %restore-context cpu ( temp1 temp2 -- ) 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 ( -- ) @@ -624,10 +610,6 @@ HOOK: %alien-callback cpu ( quot -- ) HOOK: %end-callback cpu ( -- ) -HOOK: %to-nv cpu ( -- ) - -HOOK: %from-nv cpu ( -- ) - HOOK: stack-cleanup cpu ( params -- n ) M: object stack-cleanup drop 0 ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 0307ba7f98..9734ea5dd3 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -151,11 +151,12 @@ M: x86.32 %load-param-reg [ swap local@ ] dip %copy ; #! 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 -- ) [ @@ -163,19 +164,21 @@ M:: x86.32 %box ( n rep func -- ) 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 @@ -183,38 +186,36 @@ M: x86.32 %prepare-box-struct ( -- ) ! 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 ; + "from_small_struct" f %alien-invoke + dst EAX tagged-rep %copy ; -M: x86.32 %pop-stack ( n -- ) - EAX swap ds-reg reg-stack MOV ; +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 ; -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 ; - -: 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 [ @@ -222,33 +223,15 @@ M: x86.32 %unbox-long-long ( n func -- ) [ 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 ; +M: x86 %unbox-small-struct ( src size -- ) + [ "alien_offset" call-unbox-func ] + [ + heap-size 4 > [ EDX EAX 4 [+] MOV ] when + EAX EAX [] MOV + ] bi* ; -: %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.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 @@ -257,16 +240,8 @@ M:: x86.32 %unbox-large-struct ( n c-type -- ) 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 @@ -283,10 +258,6 @@ M: x86.32 %end-callback ( -- ) 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 -- ) diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 73a4df5b45..2036b3f855 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -117,16 +117,14 @@ M: x86.64 %load-param-reg [ swap param@ ] dip %copy ; 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 ( 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 %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 %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 @@ -136,25 +134,25 @@ M:: x86.64 %unbox ( n rep func -- ) 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 @@ -169,7 +167,7 @@ M:: x86.64 %unbox-large-struct ( n c-type -- ) [ ] 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 @@ -178,7 +176,8 @@ M:: x86.64 %box ( n rep func -- ) 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@ ; @@ -188,28 +187,30 @@ M:: x86.64 %box ( n rep func -- ) { 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 @@ -217,22 +218,13 @@ M: x86.64 %prepare-box-struct ( -- ) ! 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 @@ -249,10 +241,6 @@ M: x86.64 %end-callback ( -- ) 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 ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index aa802c76fc..de39c233c9 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -180,9 +180,11 @@ M: object copy-memory* copy-register* ; 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 ; @@ -502,15 +504,11 @@ M:: x86 %check-nursery-branch ( label size cc temp1 temp2 -- ) 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 ; diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor index 1c6b37b7df..1a14ea4297 100644 --- a/basis/stack-checker/alien/alien.factor +++ b/basis/stack-checker/alien/alien.factor @@ -20,9 +20,6 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; : 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 @@ -62,7 +59,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; ! 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 @@ -76,10 +73,8 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; 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 @@ -95,7 +90,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; 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