Fix some problems with callbacks

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 -- )
+    <alien-stack-frame> ##stack-frame ;
+
 : emit-alien-node ( node quot -- next )
-    [ params>> ] dip
+    finalize-phantoms
-    [ drop <alien-stack-frame> ##stack-frame ] [ call ] 2bi
+    [ 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 ;
 

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 )

basis/compiler/codegen/codegen.factor

@@ -428,23 +428,14 @@ TUPLE: callback-context ;
 
 : %unnest-stacks ( -- ) "unnest_stacks" f %alien-invoke ;
 
-: callback-unwind ( params -- n )
+M: ##callback-return generate-insn
-    {
-        { [ dup abi>> "stdcall" = ] [ <alien-stack-frame> size>> ] }
-        { [ dup return>> large-struct? ] [ drop 4 ] }
-        [ drop 0 ]
-    } cond ;
-
-: %callback-return ( params -- )
     #! All the extra book-keeping for %unwind is only for x86.
     #! On other platforms its an alias for %return.
-    dup alien-return
+    params>> %callback-return ;
-    [ %unnest-stacks ] [ %callback-value ] if-void
-    callback-unwind %unwind ;
 
 M: ##alien-callback generate-insn
     params>>
     [ registers>objects ]
     [ wrap-callback-quot %alien-callback ]
-    [ %callback-return ]
+    [ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
     tri ;

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 ( -- )
 

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 ;

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" = ] [ <alien-stack-frame> size>> ] }
+        { [ dup return>> large-struct? ] [ drop 4 ] }
+        [ drop 0 ]
+    } cond RET ;
 
 os windows? [
     cell "longlong" c-type (>>align)

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

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 ;
 

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 -- )