From 168dd1f8254a45bb03c31cce1c1319eb3f232bd6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 28 Jul 2010 00:49:26 -0400
Subject: [PATCH] FFI rewrite part 7: compile callback bodies with the
 optimizing compiler

---
 basis/cocoa/subclassing/subclassing.factor    |  8 ---
 .../build-stack-frame.factor                  |  1 -
 basis/compiler/cfg/builder/alien/alien.factor | 20 +++---
 basis/compiler/cfg/dce/dce.factor             | 12 ++++
 .../cfg/instructions/instructions.factor      |  3 -
 basis/compiler/codegen/codegen.factor         |  1 -
 basis/compiler/tests/alien.factor             |  2 +
 basis/compiler/tree/builder/builder.factor    |  6 +-
 basis/compiler/tree/checker/checker.factor    |  2 +-
 .../tree/cleanup/cleanup-tests.factor         |  7 ++
 basis/compiler/tree/cleanup/cleanup.factor    |  3 +
 .../tree/combinators/combinators.factor       | 71 ++++++++++---------
 .../tree/dead-code/simple/simple.factor       |  3 +
 basis/compiler/tree/debugger/debugger.factor  | 13 ++--
 .../tree/escape-analysis/nodes/nodes.factor   |  2 +-
 .../tree/escape-analysis/simple/simple.factor |  3 +-
 .../tree/normalization/normalization.factor   | 15 ++--
 .../tree/propagation/nodes/nodes.factor       |  4 +-
 .../tree/propagation/simple/simple.factor     |  2 +
 .../tree/recursive/recursive-tests.factor     | 32 +++++----
 .../compiler/tree/recursive/recursive.factor  |  3 +
 basis/compiler/tree/tree.factor               |  5 +-
 .../tuple-unboxing-tests.factor               |  3 +-
 basis/cpu/architecture/architecture.factor    |  2 -
 basis/cpu/x86/32/32.factor                    |  4 --
 basis/cpu/x86/64/64.factor                    |  4 --
 basis/stack-checker/alien/alien.factor        | 49 +++++++++----
 .../stack-checker/stack-checker-tests.factor  | 28 ++++++++
 basis/stack-checker/state/state.factor        |  3 +
 .../stack-checker/visitor/dummy/dummy.factor  |  2 +-
 basis/stack-checker/visitor/visitor.factor    |  2 +-
 core/alien/alien.factor                       |  6 +-
 32 files changed, 193 insertions(+), 128 deletions(-)

diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor
index b88d3afd7b..3b88a8868c 100644
--- a/basis/cocoa/subclassing/subclassing.factor
+++ b/basis/cocoa/subclassing/subclassing.factor
@@ -95,16 +95,8 @@ SYNTAX: CLASS:
     [ [ make-local ] map ] H{ } make-assoc
     (parse-lambda) <lambda> ?rewrite-closures first ;
 
-: method-effect ( quadruple -- effect )
-    [ third ] [ second void? { } { "x" } ? ] bi <effect> ;
-
-: check-method ( quadruple -- )
-    [ fourth infer ] [ method-effect ] bi
-    2dup effect<= [ 2drop ] [ effect-error ] if ;
-
 SYNTAX: METHOD:
     scan-c-type
     parse-selector
     parse-method-body [ swap ] 2dip 4array
-    dup check-method
     suffix! ;
diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
index 41882bc78f..e2ce7d26e0 100644
--- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
+++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
@@ -39,7 +39,6 @@ M: ##unary-float-function compute-stack-frame* drop vm-frame-required ;
 M: ##binary-float-function compute-stack-frame* drop vm-frame-required ;
 
 M: ##call compute-stack-frame* drop frame-required ;
-M: ##alien-callback compute-stack-frame* drop frame-required ;
 M: ##spill compute-stack-frame* drop frame-required ;
 M: ##reload compute-stack-frame* drop frame-required ;
 
diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor
index c191628774..094b2e898b 100644
--- a/basis/compiler/cfg/builder/alien/alien.factor
+++ b/basis/compiler/cfg/builder/alien/alien.factor
@@ -173,24 +173,22 @@ M: #alien-assembly emit-node
 : needs-frame-pointer ( -- )
     cfg get t >>frame-pointer? drop ;
 
+: emit-callback-body ( nodes -- )
+    [ last #return? t assert= ] [ but-last emit-nodes ] bi ;
+
 M: #alien-callback emit-node
-    params>> dup xt>> dup
+    dup params>> xt>> dup
     [
         needs-frame-pointer
 
         begin-word
 
         {
-            [ callee-parameters ##callback-inputs ]
-            [ box-parameters ]
-            [
-                [
-                    make-kill-block
-                    quot>> ##alien-callback
-                ] emit-trivial-block
-            ]
-            [ callee-return ##callback-outputs ]
-            [ callback-stack-cleanup ]
+            [ params>> callee-parameters ##callback-inputs ]
+            [ params>> box-parameters ]
+            [ child>> emit-callback-body ]
+            [ params>> callee-return ##callback-outputs ]
+            [ params>> callback-stack-cleanup ]
         } cleave
 
         end-word
diff --git a/basis/compiler/cfg/dce/dce.factor b/basis/compiler/cfg/dce/dce.factor
index b985fbb27a..657bb9d603 100644
--- a/basis/compiler/cfg/dce/dce.factor
+++ b/basis/compiler/cfg/dce/dce.factor
@@ -99,6 +99,18 @@ M: ##write-barrier live-insn? src>> live-vreg? ;
 
 M: ##write-barrier-imm live-insn? src>> live-vreg? ;
 
+: filter-alien-outputs ( triples -- triples' )
+    [ first live-vreg? ] filter ;
+
+M: alien-call-insn live-insn?
+    [ filter-alien-outputs ] change-reg-outputs
+    drop t ;
+
+M: ##callback-inputs live-insn?
+    [ filter-alien-outputs ] change-reg-outputs
+    [ filter-alien-outputs ] change-stack-outputs
+    drop t ;
+
 M: flushable-insn live-insn? defs-vregs [ live-vreg? ] any? ;
 
 M: insn live-insn? drop t ;
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 5ce7124b4e..bfffec0aef 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -685,9 +685,6 @@ literal: reg-inputs stack-inputs reg-outputs cleanup stack-size quot gc-map ;
 VREG-INSN: ##callback-inputs
 literal: reg-outputs stack-outputs ;
 
-INSN: ##alien-callback
-literal: quot ;
-
 VREG-INSN: ##callback-outputs
 literal: reg-inputs ;
 
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 1d7f9eb14e..21a297a8a1 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -293,5 +293,4 @@ CODEGEN: ##alien-invoke %alien-invoke
 CODEGEN: ##alien-indirect %alien-indirect
 CODEGEN: ##alien-assembly %alien-assembly
 CODEGEN: ##callback-inputs %callback-inputs
-CODEGEN: ##alien-callback %alien-callback
 CODEGEN: ##callback-outputs %callback-outputs
diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
index d2c51c2302..60e132bb76 100755
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -45,6 +45,8 @@ FUNCTION: void ffi_test_0 ;
 FUNCTION: int ffi_test_1 ;
 [ 3 ] [ ffi_test_1 ] unit-test
 
+[ ] [ \ ffi_test_1 def>> [ drop ] append compile-call ] unit-test
+
 FUNCTION: int ffi_test_2 int x int y ;
 [ 5 ] [ 2 3 ffi_test_2 ] unit-test
 [ "hi" 3 ffi_test_2 ] must-fail
diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor
index 024a7bacca..d173550450 100644
--- a/basis/compiler/tree/builder/builder.factor
+++ b/basis/compiler/tree/builder/builder.factor
@@ -20,10 +20,6 @@ M: callable (build-tree) infer-quot-here ;
 : check-no-compile ( word -- )
     dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ;
 
-: check-effect ( word effect -- )
-    swap required-stack-effect 2dup effect<=
-    [ 2drop ] [ effect-error ] if ;
-
 : inline-recursive? ( word -- ? )
     [ "inline" word-prop ] [ "recursive" word-prop ] bi and ;
 
@@ -33,7 +29,7 @@ M: callable (build-tree) infer-quot-here ;
 M: word (build-tree)
     [ check-no-compile ]
     [ word-body infer-quot-here ]
-    [ current-effect check-effect ] tri ;
+    [ required-stack-effect check-effect ] tri ;
 
 : build-tree-with ( in-stack word/quot -- nodes )
     [
diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor
index a3a19b8f4d..314e7ad1db 100644
--- a/basis/compiler/tree/checker/checker.factor
+++ b/basis/compiler/tree/checker/checker.factor
@@ -188,7 +188,7 @@ M: #copy check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
 
 M: #alien-node check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
 
-M: #alien-callback check-stack-flow* drop ;
+M: #alien-callback check-stack-flow* child>> check-stack-flow ;
 
 M: #declare check-stack-flow* drop ;
 
diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor
index 05f9092ee1..4947cb365d 100644
--- a/basis/compiler/tree/cleanup/cleanup-tests.factor
+++ b/basis/compiler/tree/cleanup/cleanup-tests.factor
@@ -519,3 +519,10 @@ cell-bits 32 = [
         14 ndrop
     ] cleaned-up-tree nodes>quot
 ] unit-test
+
+USING: alien alien.c-types ;
+
+[ t ] [
+    [ int { } cdecl [ 2 2 + ] alien-callback ]
+    { + } inlined?
+] unit-test
diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor
index b69f053898..616a848366 100644
--- a/basis/compiler/tree/cleanup/cleanup.factor
+++ b/basis/compiler/tree/cleanup/cleanup.factor
@@ -182,4 +182,7 @@ M: #recursive cleanup*
     [ cleanup ] change-child
     dup label>> calls>> empty? [ flatten-recursive ] when ;
 
+M: #alien-callback cleanup*
+    [ cleanup ] change-child ;
+
 M: node cleanup* ;
diff --git a/basis/compiler/tree/combinators/combinators.factor b/basis/compiler/tree/combinators/combinators.factor
index 69c48c5f94..596cf7fd20 100644
--- a/basis/compiler/tree/combinators/combinators.factor
+++ b/basis/compiler/tree/combinators/combinators.factor
@@ -1,46 +1,47 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs fry kernel accessors sequences compiler.utilities
-arrays stack-checker.inlining namespaces compiler.tree
-math.order ;
+USING: assocs combinators combinators.short-circuit fry kernel
+locals accessors sequences compiler.utilities arrays
+stack-checker.inlining namespaces compiler.tree math.order ;
 IN: compiler.tree.combinators
 
-: each-node ( ... nodes quot: ( ... node -- ... ) -- ... )
-    dup dup '[
-        _ [
-            dup #branch? [
-                children>> [ _ each-node ] each
-            ] [
-                dup #recursive? [
-                    child>> _ each-node
-                ] [ drop ] if
-            ] if
+:: each-node ( ... nodes quot: ( ... node -- ... ) -- ... )
+    nodes [
+        quot
+        [
+            {
+                { [ dup #branch? ] [ children>> [ quot each-node ] each ] }
+                { [ dup #recursive? ] [ child>> quot each-node ] }
+                { [ dup #alien-callback? ] [ child>> quot each-node ] }
+                [ drop ]
+            } cond
         ] bi
     ] each ; inline recursive
 
-: map-nodes ( ... nodes quot: ( ... node -- ... node' ) -- ... nodes )
-    dup dup '[
-        @
-        dup #branch? [
-            [ [ _ map-nodes ] map ] change-children
-        ] [
-            dup #recursive? [
-                [ _ map-nodes ] change-child
-            ] when
-        ] if
+:: map-nodes ( ... nodes quot: ( ... node -- ... node' ) -- ... nodes )
+    nodes [
+        quot call
+        {
+            { [ dup #branch? ] [ [ [ quot map-nodes ] map ] change-children ] }
+            { [ dup #recursive? ] [ [ quot map-nodes ] change-child ] }
+            { [ dup #alien-callback? ] [ [ quot map-nodes ] change-child ] }
+            [ ]
+        } cond
     ] map-flat ; inline recursive
 
-: contains-node? ( ... nodes quot: ( ... node -- ... ? ) -- ... ? )
-    dup dup '[
-        _ keep swap [ drop t ] [
-            dup #branch? [
-                children>> [ _ contains-node? ] any?
-            ] [
-                dup #recursive? [
-                    child>> _ contains-node?
-                ] [ drop f ] if
-            ] if
-        ] if
+:: contains-node? ( ... nodes quot: ( ... node -- ... ? ) -- ... ? )
+    nodes [
+        {
+            quot
+            [
+                {
+                    { [ dup #branch? ] [ children>> [ quot contains-node? ] any? ] }
+                    { [ dup #recursive? ] [ child>> quot contains-node? ] }
+                    { [ dup #alien-callback? ] [ child>> quot contains-node? ] }
+                    [ drop f ]
+                } cond
+            ]
+        } 1||
     ] any? ; inline recursive
 
 : select-children ( seq flags -- seq' )
diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor
index 5582f4dc6f..46da6232df 100644
--- a/basis/compiler/tree/dead-code/simple/simple.factor
+++ b/basis/compiler/tree/dead-code/simple/simple.factor
@@ -117,3 +117,6 @@ M: #terminate remove-dead-code*
 
 M: #alien-node remove-dead-code*
     maybe-drop-dead-outputs ;
+
+M: #alien-callback remove-dead-code*
+    [ (remove-dead-code) ] change-child ;
diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor
index 7350a35de9..06b5cc927c 100644
--- a/basis/compiler/tree/debugger/debugger.factor
+++ b/basis/compiler/tree/debugger/debugger.factor
@@ -4,7 +4,7 @@ USING: kernel assocs match fry accessors namespaces make effects
 sequences sequences.private quotations generic macros arrays
 prettyprint prettyprint.backend prettyprint.custom
 prettyprint.sections math words combinators
-combinators.short-circuit io sorting hints
+combinators.short-circuit io sorting hints sets
 compiler.tree
 compiler.tree.recursive
 compiler.tree.normalization
@@ -22,6 +22,7 @@ compiler.tree.identities
 compiler.tree.dead-code
 compiler.tree.modular-arithmetic ;
 FROM: fry => _ ;
+FROM: namespaces => set ;
 RENAME: _ match => __
 IN: compiler.tree.debugger
 
@@ -128,7 +129,8 @@ M: #alien-indirect node>quot params>> , \ #alien-indirect , ;
 
 M: #alien-assembly node>quot params>> , \ #alien-assembly , ;
 
-M: #alien-callback node>quot params>> , \ #alien-callback , ;
+M: #alien-callback node>quot
+    [ params>> , ] [ child>> nodes>quot , ] bi \ #alien-callback , ;
 
 M: node node>quot drop ;
 
@@ -222,7 +224,6 @@ SYMBOL: node-count
     ] with-scope ;
 
 : inlined? ( quot seq/word -- ? )
-    [ cleaned-up-tree ] dip
-    dup word? [ 1array ] when
-    '[ dup #call? [ word>> _ member? ] [ drop f ] if ]
-    contains-node? not ;
+    dup word? [ 1array ] when swap
+    [ cleaned-up-tree [ dup #call? [ word>> , ] [ drop ] if ] each-node ] V{ } make
+    intersect empty? ;
diff --git a/basis/compiler/tree/escape-analysis/nodes/nodes.factor b/basis/compiler/tree/escape-analysis/nodes/nodes.factor
index 4c9dc1ade7..6fcfa16261 100644
--- a/basis/compiler/tree/escape-analysis/nodes/nodes.factor
+++ b/basis/compiler/tree/escape-analysis/nodes/nodes.factor
@@ -13,7 +13,7 @@ SYMBOL: next-node
 : each-with-next ( ... seq quot: ( ... elt -- ... ) -- ... )
     dupd '[ 1 + _ ?nth next-node set @ ] each-index ; inline
 
-: (escape-analysis) ( node -- )
+: (escape-analysis) ( nodes -- )
     [
         [ node-defs-values introduce-values ]
         [ escape-analysis* ]
diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor
index 9634bdf259..ecdd10fee7 100644
--- a/basis/compiler/tree/escape-analysis/simple/simple.factor
+++ b/basis/compiler/tree/escape-analysis/simple/simple.factor
@@ -100,4 +100,5 @@ M: #alien-node escape-analysis*
     [ out-d>> unknown-allocations ]
     bi ;
 
-M: #alien-callback escape-analysis* drop ;
+M: #alien-callback escape-analysis*
+    child>> (escape-analysis) ;
diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor
index 7912fce1f6..bfacae6ad5 100644
--- a/basis/compiler/tree/normalization/normalization.factor
+++ b/basis/compiler/tree/normalization/normalization.factor
@@ -109,8 +109,13 @@ M: #call-recursive normalize*
 M: node normalize* ;
 
 : normalize ( nodes -- nodes' )
-    dup count-introductions make-values
-    H{ } clone rename-map set
-    [ (normalize) ] [ nip ] 2bi
-    [ #introduce prefix ] unless-empty
-    rename-node-values ;
+    [
+        dup count-introductions make-values
+        H{ } clone rename-map set
+        [ (normalize) ] [ nip ] 2bi
+        [ #introduce prefix ] unless-empty
+        rename-node-values
+    ] with-scope ;
+
+M: #alien-callback normalize*
+    [ normalize ] change-child ;
diff --git a/basis/compiler/tree/propagation/nodes/nodes.factor b/basis/compiler/tree/propagation/nodes/nodes.factor
index c3f5312601..1827881e9a 100644
--- a/basis/compiler/tree/propagation/nodes/nodes.factor
+++ b/basis/compiler/tree/propagation/nodes/nodes.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: sequences accessors kernel assocs
 compiler.tree
@@ -16,7 +16,7 @@ GENERIC: annotate-node ( node -- )
 
 GENERIC: propagate-around ( node -- )
 
-: (propagate) ( node -- )
+: (propagate) ( nodes -- )
     [ [ compute-copy-equiv ] [ propagate-around ] bi ] each ;
 
 : extract-value-info ( values -- assoc )
diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor
index ce169233c1..c6a1dbf73f 100644
--- a/basis/compiler/tree/propagation/simple/simple.factor
+++ b/basis/compiler/tree/propagation/simple/simple.factor
@@ -153,4 +153,6 @@ M: #call propagate-after
 
 M: #alien-node propagate-before propagate-alien-invoke ;
 
+M: #alien-callback propagate-around child>> (propagate) ;
+
 M: #return annotate-node dup in-d>> (annotate-node) ;
diff --git a/basis/compiler/tree/recursive/recursive-tests.factor b/basis/compiler/tree/recursive/recursive-tests.factor
index 4c4220f238..967d5c9a33 100644
--- a/basis/compiler/tree/recursive/recursive-tests.factor
+++ b/basis/compiler/tree/recursive/recursive-tests.factor
@@ -1,4 +1,4 @@
-USING: tools.test kernel combinators.short-circuit math sequences accessors
+USING: tools.test kernel combinators.short-circuit math sequences accessors make
 compiler.tree
 compiler.tree.builder
 compiler.tree.combinators
@@ -12,22 +12,24 @@ IN: compiler.tree.recursive.tests
 [ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test
 
 : label-is-loop? ( nodes word -- ? )
-    [
-        {
-            [ drop #recursive? ]
-            [ drop label>> loop?>> ]
-            [ swap label>> word>> eq? ]
-        } 2&&
-    ] curry contains-node? ;
+    swap [
+        [
+            dup {
+                [ #recursive? ]
+                [ label>> loop?>> ]
+            } 1&& [ label>> word>> , ] [ drop ] if
+        ] each-node
+    ] V{ } make member? ;
 
 : label-is-not-loop? ( nodes word -- ? )
-    [
-        {
-            [ drop #recursive? ]
-            [ drop label>> loop?>> not ]
-            [ swap label>> word>> eq? ]
-        } 2&&
-    ] curry contains-node? ;
+    swap [
+        [
+            dup {
+                [ #recursive? ]
+                [ label>> loop?>> not ]
+            } 1&& [ label>> word>> , ] [ drop ] if
+        ] each-node
+    ] V{ } make member? ;
 
 : loop-test-1 ( a -- )
     dup [ 1 + loop-test-1 ] [ drop ] if ; inline recursive
diff --git a/basis/compiler/tree/recursive/recursive.factor b/basis/compiler/tree/recursive/recursive.factor
index 70c4fb44d9..ccd4b47643 100644
--- a/basis/compiler/tree/recursive/recursive.factor
+++ b/basis/compiler/tree/recursive/recursive.factor
@@ -61,6 +61,9 @@ M: #recursive node-call-graph
 M: #branch node-call-graph
     children>> [ (build-call-graph) ] with each ;
 
+M: #alien-callback node-call-graph
+    child>> (build-call-graph) ;
+
 M: node node-call-graph 2drop ;
 
 SYMBOLS: not-loops recursive-nesting ;
diff --git a/basis/compiler/tree/tree.factor b/basis/compiler/tree/tree.factor
index a1d1b4db61..d75b6ae6cf 100644
--- a/basis/compiler/tree/tree.factor
+++ b/basis/compiler/tree/tree.factor
@@ -154,10 +154,11 @@ TUPLE: #alien-assembly < #alien-node in-d out-d ;
 : #alien-assembly ( params -- node )
     \ #alien-assembly new-alien-node ;
 
-TUPLE: #alien-callback < node params ;
+TUPLE: #alien-callback < node params child ;
 
-: #alien-callback ( params -- node )
+: #alien-callback ( params child -- node )
     \ #alien-callback new
+        swap >>child
         swap >>params ;
 
 : node, ( node -- ) stack-visitor get push ;
diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
index e6d42f0289..6f70035fed 100644
--- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
+++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
@@ -5,7 +5,7 @@ compiler.tree.cleanup compiler.tree.escape-analysis
 compiler.tree.tuple-unboxing compiler.tree.checker
 compiler.tree.def-use kernel accessors sequences math
 math.private sorting math.order binary-search sequences.private
-slots.private ;
+slots.private alien alien.c-types ;
 IN: compiler.tree.tuple-unboxing.tests
 
 : test-unboxing ( quot -- )
@@ -35,6 +35,7 @@ TUPLE: empty-tuple ;
     [ 1 cons boa over [ "A" throw ] when car>> ]
     [ [ <=> ] sort ]
     [ [ <=> ] with search ]
+    [ cons boa car>> void { } cdecl [ ] alien-callback ]
 } [ [ ] swap [ test-unboxing ] curry unit-test ] each
 
 ! A more complicated example
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index d40450e298..96ca9d0b32 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -610,8 +610,6 @@ HOOK: %alien-assembly cpu ( reg-inputs stack-inputs reg-outputs cleanup stack-si
 
 HOOK: %callback-inputs cpu ( reg-outputs stack-outputs -- )
 
-HOOK: %alien-callback cpu ( quot -- )
-
 HOOK: %callback-outputs cpu ( reg-inputs -- )
 
 HOOK: stack-cleanup cpu ( stack-size return abi -- n )
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 3808fb47ba..79dd9e743d 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -186,10 +186,6 @@ M: x86.32 %begin-callback ( -- )
     4 stack@ 0 MOV
     "begin_callback" f f %c-invoke ;
 
-M: x86.32 %alien-callback ( quot -- )
-    [ EAX ] dip %load-reference
-    EAX quot-entry-point-offset [+] CALL ;
-
 M: x86.32 %end-callback ( -- )
     0 save-vm-ptr
     "end_callback" f f %c-invoke ;
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index fad1a747e6..f12dc0a15c 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -116,10 +116,6 @@ M: x86.64 %begin-callback ( -- )
     param-reg-1 0 MOV
     "begin_callback" f f %c-invoke ;
 
-M: x86.64 %alien-callback ( quot -- )
-    [ param-reg-0 ] dip %load-reference
-    param-reg-0 quot-entry-point-offset [+] CALL ;
-
 M: x86.64 %end-callback ( -- )
     param-reg-0 %mov-vm-ptr
     "end_callback" f f %c-invoke ;
diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor
index 42c87f05b9..5489db00ab 100644
--- a/basis/stack-checker/alien/alien.factor
+++ b/basis/stack-checker/alien/alien.factor
@@ -4,7 +4,8 @@ USING: kernel arrays sequences accessors combinators math
 namespaces init sets words assocs alien.libraries alien
 alien.private alien.c-types fry quotations strings
 stack-checker.backend stack-checker.errors stack-checker.visitor
-stack-checker.dependencies compiler.utilities ;
+stack-checker.dependencies stack-checker.state
+compiler.utilities effects ;
 IN: stack-checker.alien
 
 TUPLE: alien-node-params
@@ -19,7 +20,7 @@ TUPLE: alien-indirect-params < alien-node-params ;
 
 TUPLE: alien-assembly-params < alien-node-params { quot callable } ;
 
-TUPLE: alien-callback-params < alien-node-params { quot callable } xt ;
+TUPLE: alien-callback-params < alien-node-params xt ;
 
 : param-prep-quot ( params -- quot )
     parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
@@ -106,6 +107,7 @@ TUPLE: alien-callback-params < alien-node-params { quot callable } xt ;
     callbacks get [ dup "stack-cleanup" word-prop <callback> ] cache ;
 
 : callback-bottom ( params -- )
+    "( callback )" <uninterned-word> >>xt
     xt>> '[ _ callback-xt ] infer-quot-here ;
 
 : callback-return-quot ( ctype -- quot )
@@ -114,19 +116,36 @@ TUPLE: alien-callback-params < alien-node-params { quot callable } xt ;
 : callback-prep-quot ( params -- quot )
     parameters>> [ c-type c-type-boxer-quot ] map spread>quot ;
 
-: wrap-callback-quot ( params -- quot )
-    [ callback-prep-quot ] [ quot>> ] [ callback-return-quot ] tri 3append
-     yield-hook get
-     '[ _ _ do-callback ]
-     >quotation ;
+GENERIC: wrap-callback-quot ( params quot -- quot' )
+
+M: callable wrap-callback-quot
+    swap [ callback-prep-quot ] [ callback-return-quot ] bi surround
+    yield-hook get
+    '[ _ _ do-callback ]
+    >quotation ;
+
+: callback-effect ( params -- effect )
+    [ parameters>> length "x" <array> ] [ return>> void? { } { "x" } ? ] bi
+    <effect> ;
+
+: infer-callback-quot ( params quot -- child )
+    [
+        init-inference
+        nest-visitor
+        infer-quot-here
+        end-infer
+        callback-effect check-effect
+        stack-visitor get
+    ] with-scope ;
 
 : infer-alien-callback ( -- )
-    alien-callback-params new
-    pop-quot
-    pop-abi
-    pop-params
-    pop-return
-    "( callback )" <uninterned-word> >>xt
-    dup wrap-callback-quot >>quot
-    dup callback-bottom
+    pop-literal nip [
+        alien-callback-params new
+        pop-abi
+        pop-params
+        pop-return
+        dup callback-bottom
+        dup
+        dup
+    ] dip wrap-callback-quot infer-callback-quot
     #alien-callback, ;
diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor
index 351cf5cde0..417b7fbed0 100644
--- a/basis/stack-checker/stack-checker-tests.factor
+++ b/basis/stack-checker/stack-checker-tests.factor
@@ -473,3 +473,31 @@ FROM: splitting.private => split, ;
 ! M\ declared-effect infer-call* didn't properly unify branches
 { 1 0 } [ [ 1 [ drop ] [ drop ] if ] each ] must-infer-as
 
+! Make sure alien-callback effects are checked properly
+USING: alien.c-types alien ;
+
+[ void { } cdecl [ ] alien-callback ] must-infer
+
+[ [ void { } cdecl [ f [ drop ] unless ] alien-callback ] infer ] [ unbalanced-branches-error? ] must-fail-with
+
+[ [ void { } cdecl [ drop ] alien-callback ] infer ] [ effect-error? ] must-fail-with
+
+[ [ int { } cdecl [ ] alien-callback ] infer ] [ effect-error? ] must-fail-with
+
+[ int { } cdecl [ 5 ] alien-callback ] must-infer
+
+[ int { int } cdecl [ ] alien-callback ] must-infer
+
+[ int { int } cdecl [ 1 + ] alien-callback ] must-infer
+
+[ void { int } cdecl [ . ] alien-callback ] must-infer
+
+: recursive-callback-1 ( -- x )
+    void { } cdecl [ recursive-callback-1 drop ] alien-callback ;
+
+\ recursive-callback-1 def>> must-infer
+
+: recursive-callback-2 ( -- x )
+    void { } cdecl [ recursive-callback-2 drop ] alien-callback ; inline recursive
+
+[ recursive-callback-2 ] must-infer
diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor
index 3ac6a4531f..0469f45858 100644
--- a/basis/stack-checker/state/state.factor
+++ b/basis/stack-checker/state/state.factor
@@ -43,6 +43,9 @@ SYMBOL: literals
     meta-d length "x" <array>
     terminated? get <terminated-effect> ;
 
+: check-effect ( required-effect -- )
+    [ current-effect ] dip 2dup effect<= [ 2drop ] [ effect-error ] if ;
+
 : init-inference ( -- )
     terminated? off
     V{ } clone \ meta-d set
diff --git a/basis/stack-checker/visitor/dummy/dummy.factor b/basis/stack-checker/visitor/dummy/dummy.factor
index 871f79d320..3011aac10b 100644
--- a/basis/stack-checker/visitor/dummy/dummy.factor
+++ b/basis/stack-checker/visitor/dummy/dummy.factor
@@ -25,4 +25,4 @@ M: f #drop, drop ;
 M: f #alien-invoke, drop ;
 M: f #alien-indirect, drop ;
 M: f #alien-assembly, drop ;
-M: f #alien-callback, drop ;
+M: f #alien-callback, 2drop ;
diff --git a/basis/stack-checker/visitor/visitor.factor b/basis/stack-checker/visitor/visitor.factor
index d4207caf5b..5871f73a4a 100644
--- a/basis/stack-checker/visitor/visitor.factor
+++ b/basis/stack-checker/visitor/visitor.factor
@@ -30,4 +30,4 @@ HOOK: #copy, stack-visitor ( inputs outputs -- )
 HOOK: #alien-invoke, stack-visitor ( params -- )
 HOOK: #alien-indirect, stack-visitor ( params -- )
 HOOK: #alien-assembly, stack-visitor ( params -- )
-HOOK: #alien-callback, stack-visitor ( params -- )
+HOOK: #alien-callback, stack-visitor ( params child -- )
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index d67e0a12b9..98b1d6428c 100755
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -106,12 +106,12 @@ SYMBOL: callbacks
 ! returning from it, to avoid a bad interaction between threads
 ! and callbacks. See basis/compiler/tests/alien.factor for a
 ! test case.
-: wait-to-return ( yield-quot callback-id -- )
+: wait-to-return ( yield-quot: ( -- ) callback-id -- )
     dup current-callback eq?
-    [ 2drop ] [ over call( -- ) wait-to-return ] if ;
+    [ 2drop ] [ over call wait-to-return ] if ; inline recursive
 
 ! Used by compiler.codegen to wrap callback bodies
-: do-callback ( callback-quot yield-quot -- )
+: do-callback ( callback-quot yield-quot: ( -- ) -- )
     init-namespaces
     init-catchstack
     current-callback