diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor index d3bcbd3517..be01a2886e 100644 --- a/basis/compiler/cfg/builder/alien/alien.factor +++ b/basis/compiler/cfg/builder/alien/alien.factor @@ -3,7 +3,7 @@ USING: accessors arrays layouts math math.order math.parser combinators combinators.short-circuit fry make sequences locals alien alien.private alien.strings alien.c-types alien.libraries -classes.struct namespaces kernel strings libc quotations +classes.struct namespaces kernel strings libc quotations words cpu.architecture compiler.utilities compiler.tree compiler.cfg compiler.cfg.builder compiler.cfg.builder.alien.params compiler.cfg.builder.blocks compiler.cfg.instructions @@ -151,9 +151,9 @@ M: array dlsym-valid? '[ _ dlsym ] any? ; t >>calls-vm? ; : emit-stack-frame ( stack-size params -- ) - return>> + [ return>> ] [ abi>> ] bi [ stack-cleanup ##cleanup ] - [ ##stack-frame ] bi ; + [ drop ##stack-frame ] 3bi ; M: #alien-invoke emit-node [ @@ -295,6 +295,17 @@ M: struct-c-type unbox-return [ alien-parameters [ stack-size ] map-sum ] [ return>> ] bi ##stack-frame ; +: stack-args-size ( params -- n ) + dup abi>> [ + alien-parameters flatten-c-types + [ alloc-parameter 2drop ] each + stack-params get + ] with-param-regs ; + +: callback-stack-cleanup ( params -- ) + [ xt>> ] [ [ stack-args-size ] [ return>> ] [ abi>> ] tri stack-cleanup ] bi + "stack-cleanup" set-word-prop ; + M: #alien-callback emit-node dup params>> xt>> dup [ @@ -303,6 +314,7 @@ M: #alien-callback emit-node { [ registers>objects ] [ emit-callback-stack-frame ] + [ callback-stack-cleanup ] [ wrap-callback-quot ##alien-callback ] [ return>> { diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 3aa1f67356..b97c45253b 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -605,6 +605,6 @@ HOOK: %alien-callback cpu ( quot -- ) HOOK: %end-callback cpu ( -- ) -HOOK: stack-cleanup cpu ( params -- n ) +HOOK: stack-cleanup cpu ( stack-size return abi -- n ) -M: object stack-cleanup drop 0 ; +M: object stack-cleanup 3drop 0 ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index bbd304ee47..f663523999 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -3,14 +3,10 @@ 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 -command-line make words compiler compiler.units -compiler.constants compiler.alien compiler.codegen -compiler.codegen.fixup compiler.cfg.instructions -compiler.cfg.builder compiler.cfg.builder.alien -compiler.cfg.builder.alien.params -compiler.cfg.intrinsics compiler.cfg.stack-frame -cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 -cpu.architecture vm ; +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 ; FROM: layouts => cell ; IN: cpu.x86.32 @@ -279,28 +275,19 @@ M:: x86.32 %binary-float-function ( dst src1 src2 func -- ) func "libm" load-library %alien-invoke dst float-function-return ; -: funny-large-struct-return? ( params -- ? ) +: funny-large-struct-return? ( return abi -- ? ) #! MINGW ABI incompatibility disaster - [ return>> large-struct? ] - [ abi>> mingw eq? os windows? not or ] - bi and ; + [ large-struct? ] [ mingw eq? os windows? not or ] bi* and ; -: stack-arg-size ( params -- n ) - dup abi>> [ - alien-parameters flatten-c-types - [ alloc-parameter 2drop ] each - stack-params get - ] with-param-regs ; - -M: x86.32 stack-cleanup ( params -- n ) +M:: x86.32 stack-cleanup ( stack-size return abi -- n ) #! a) Functions which are stdcall/fastcall/thiscall have to #! clean up the caller's stack frame. #! b) Functions returning large structs on MINGW have to #! fix ESP. { - { [ dup abi>> callee-cleanup? ] [ stack-arg-size ] } - { [ dup funny-large-struct-return? ] [ drop 4 ] } - [ drop 0 ] + { [ abi callee-cleanup? ] [ stack-size ] } + { [ return abi funny-large-struct-return? ] [ 4 ] } + [ 0 ] } cond ; M: x86.32 %cleanup ( n -- ) diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor index 1a14ea4297..62dd65c5e0 100644 --- a/basis/stack-checker/alien/alien.factor +++ b/basis/stack-checker/alien/alien.factor @@ -2,7 +2,7 @@ ! 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 cpu.architecture fry stack-checker.backend +alien.c-types fry stack-checker.backend stack-checker.errors stack-checker.visitor stack-checker.dependencies ; IN: stack-checker.alien @@ -98,11 +98,11 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; ! Quotation which coerces return value to required type infer-return ; -: callback-xt ( word return-rewind -- alien ) - [ callbacks get ] dip '[ _ ] cache ; +: callback-xt ( word -- alien ) + callbacks get [ dup "stack-cleanup" word-prop ] cache ; : callback-bottom ( params -- ) - [ xt>> ] [ stack-cleanup ] bi '[ _ _ callback-xt ] infer-quot-here ; + xt>> '[ _ callback-xt ] infer-quot-here ; : infer-alien-callback ( -- ) alien-callback-params new