diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index df437024b7..3bc4a738c1 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -332,9 +332,12 @@ M: #terminate emit-node [ alien-parameters parameter-sizes drop >>params ] bi dup [ params>> ] [ return>> ] bi + >>size ; +: alien-stack-frame ( params -- ) + ##stack-frame ; + : emit-alien-node ( node quot -- next ) - [ params>> ] dip - [ drop ##stack-frame ] [ call ] 2bi + finalize-phantoms + [ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi iterate-next ; inline M: #alien-invoke emit-node @@ -347,7 +350,10 @@ M: #alien-callback emit-node dup params>> xt>> dup [ init-phantoms - [ ##alien-callback ] emit-alien-node drop + ##prologue + dup [ ##alien-callback ] emit-alien-node drop + ##epilogue + params>> ##callback-return ] with-cfg-builder iterate-next ; diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 8edcab70c2..d92520c77d 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -56,6 +56,7 @@ INSN: ##gc ; INSN: ##alien-invoke params ; INSN: ##alien-indirect params ; INSN: ##alien-callback params ; +INSN: ##callback-return params ; GENERIC: defs-vregs ( insn -- seq ) GENERIC: uses-vregs ( insn -- seq ) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index a35960117c..0a79d14778 100644 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -428,23 +428,14 @@ TUPLE: callback-context ; : %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ; -: callback-unwind ( params -- n ) - { - { [ dup abi>> "stdcall" = ] [ size>> ] } - { [ dup return>> large-struct? ] [ drop 4 ] } - [ drop 0 ] - } cond ; - -: %callback-return ( params -- ) +M: ##callback-return generate-insn #! All the extra book-keeping for %unwind is only for x86. #! On other platforms its an alias for %return. - dup alien-return - [ %unnest-stacks ] [ %callback-value ] if-void - callback-unwind %unwind ; + params>> %callback-return ; M: ##alien-callback generate-insn params>> [ registers>objects ] [ wrap-callback-quot %alien-callback ] - [ %callback-return ] + [ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ] tri ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 66d7b35518..31cd979025 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -137,14 +137,18 @@ M: object %prepare-var-args ; HOOK: %alien-invoke cpu ( function library -- ) -HOOK: %cleanup cpu ( alien-node -- ) +HOOK: %cleanup cpu ( params -- ) + +M: object %cleanup ( params -- ) drop ; HOOK: %alien-callback cpu ( quot -- ) HOOK: %callback-value cpu ( ctype -- ) ! Return to caller with stdcall unwinding (only for x86) -HOOK: %unwind cpu ( n -- ) +HOOK: %callback-return cpu ( params -- ) + +M: object %callback-return drop %return ; HOOK: %prepare-alien-indirect cpu ( -- ) diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor index 117ab51fe2..f19b71f3e4 100644 --- a/basis/cpu/ppc/architecture/architecture.factor +++ b/basis/cpu/ppc/architecture/architecture.factor @@ -128,8 +128,6 @@ M: ppc %dispatch-label ( word -- ) M: ppc %return ( -- ) %epilogue-later BLR ; -M: ppc %unwind drop %return ; - M: ppc %peek ( vreg loc -- ) >r v>operand r> loc>operand LWZ ; @@ -267,8 +265,6 @@ M: ppc %callback-value ( ctype -- ) ! Unbox former top of data stack to return registers unbox-return ; -M: ppc %cleanup ( alien-node -- ) drop ; - : %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ; : %tag-fixnum ( src dest -- ) tag-bits get SLWI ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 67809c4d91..a170878eec 100644 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -244,7 +244,7 @@ M: x86.32 %callback-value ( ctype -- ) ! Unbox EAX unbox-return ; -M: x86.32 %cleanup ( alien-node -- ) +M: x86.32 %cleanup ( params -- ) #! a) If we just called an stdcall function in Windows, it #! cleaned up the stack frame for us. But we don't want that #! so we 'undo' the cleanup since we do that in %epilogue. @@ -261,7 +261,16 @@ M: x86.32 %cleanup ( alien-node -- ) [ drop ] } cond ; -M: x86.32 %unwind ( n -- ) RET ; +M: x86.32 %callback-return ( n -- ) + #! a) If the callback is stdcall, we have to clean up the + #! caller's stack frame. + #! b) If the callback is returning a large struct, we have + #! to fix ESP. + { + { [ dup abi>> "stdcall" = ] [ size>> ] } + { [ dup return>> large-struct? ] [ drop 4 ] } + [ drop 0 ] + } cond RET ; os windows? [ cell "longlong" c-type (>>align) diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 6a3d272dfb..07ee01270a 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -222,10 +222,6 @@ M: x86.64 %callback-value ( ctype -- ) ! Unbox former top of data stack to return registers unbox-return ; -M: x86.64 %cleanup ( alien-node -- ) drop ; - -M: x86.64 %unwind ( n -- ) drop 0 RET ; - USE: cpu.x86.intrinsics ! On 64-bit systems, the result of reading 4 bytes from memory diff --git a/basis/cpu/x86/allot/allot.factor b/basis/cpu/x86/allot/allot.factor index 425479dc89..13d81e0d89 100644 --- a/basis/cpu/x86/allot/allot.factor +++ b/basis/cpu/x86/allot/allot.factor @@ -100,7 +100,7 @@ M:: x86 %box-alien ( dst src temp -- ) dst 3 alien@ src MOV "end" get JMP "f" resolve-label - \ f tag-number MOV + dst \ f tag-number MOV "end" resolve-label ] with-scope ; diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor index d08ef85173..d4b5efd378 100644 --- a/basis/cpu/x86/architecture/architecture.factor +++ b/basis/cpu/x86/architecture/architecture.factor @@ -149,7 +149,7 @@ M: x86 small-enough? ( n -- ? ) : %tag-fixnum ( reg -- ) tag-bits get SHL ; -M: x86 %return ( -- ) 0 %unwind ; +M: x86 %return ( -- ) 0 RET ; ! Alien intrinsics M: x86 %unbox-byte-array ( dst src -- )