Refactor x86-32 stack cleanup logic

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 ]
-    [ <alien-stack-frame> ##stack-frame ] bi ;
+    [ drop <alien-stack-frame> ##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
     <alien-stack-frame> ##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>> {

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 ;

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
+make words compiler.constants compiler.codegen.fixup
-compiler.constants compiler.alien compiler.codegen
+compiler.cfg.instructions compiler.cfg.builder compiler.cfg.intrinsics
-compiler.codegen.fixup compiler.cfg.instructions
+compiler.cfg.stack-frame cpu.x86.assembler cpu.x86.assembler.operands
-compiler.cfg.builder compiler.cfg.builder.alien
+cpu.x86 cpu.architecture vm ;
-compiler.cfg.builder.alien.params
-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? ]
+    [ large-struct? ] [ mingw eq? os windows? not or ] bi* and ;
-    [ abi>> mingw eq? os windows? not or ]
-    bi and ;
 
-: stack-arg-size ( params -- n )
+M:: x86.32 stack-cleanup ( stack-size return abi -- 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 )
     #! 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 ] }
+        { [ abi callee-cleanup? ] [ stack-size ] }
-        { [ dup funny-large-struct-return? ] [ drop 4 ] }
+        { [ return abi funny-large-struct-return? ] [ 4 ] }
-        [ drop 0 ]
+        [ 0 ]
     } cond ;
 
 M: x86.32 %cleanup ( n -- )

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 )
+: callback-xt ( word -- alien )
-    [ callbacks get ] dip '[ _ <callback> ] cache ;
+    callbacks get [ dup "stack-cleanup" word-prop <callback> ] 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