FFI rewrite part 7: compile callback bodies with the optimizing compiler

diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor
index b88d3afd7b0b89d784d66e9e53a1d2505fde817c..3b88a8868c071fab8c487afa19f43f02e8bf960b 100644 (file)
--- 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 41882bc78ff0314b2391984a8efcea568a3a504b..e2ce7d26e035de1ca12a1e85badfa1f7ff248861 100644 (file)
--- 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 c191628774c2088084d4bbec0ebb716f29ab6730..094b2e898b5ba1b3afb7f8f3a37525340fe4b9ff 100644 (file)
--- 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 b985fbb27a8ce3715d7c77e8a396a457355dae86..657bb9d6030ee0de9298e82775a35e602e51d039 100644 (file)
--- 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 5ce7124b4ee8ce6f578fde5fcceaf461f4af1598..bfffec0aefc9144b77ba7085f0e2a28a39571293 100644 (file)
--- 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 1d7f9eb14e62ac634a282a143231ecf4693a8703..21a297a8a137043086e9746ddb8ba42d657f95a7 100755 (executable)
--- 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 d2c51c23026280c0abd5c66c774553a1d04cc738..60e132bb76531ad0b7d0a96ea695333cb2d77cfb 100755 (executable)
--- 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 024a7baccabab00c3693fde9a8309afc8f1d9e57..d1735504503034a64214f594293357e79374195a 100644 (file)
--- 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 a3a19b8f4d6bf86c614d8dd0d06144968b6ede3b..314e7ad1db507f6bf2985584a8d4ed9b61e8be80 100644 (file)
--- 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 05f9092ee130fe95ee6e3f72e607fabc95beaed5..4947cb365d544b9c269e4382ec67b76750090b5b 100644 (file)
--- 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 b69f0538985384250aa5bdd9b2d6f9a3c52d1cea..616a848366b75912d8029ca62ce52c0680d27aa9 100644 (file)
--- 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 69c48c5f94f83147f06692ab3f695f14a346ab9c..596cf7fd20076c8771281faedb09a5538d3cbd16 100644 (file)
--- 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 5582f4dc6fe07519b7b58fdbf91352cfc7399c00..46da6232dfb40efa8154ef9f4f018f8e23b5dbbb 100644 (file)
--- 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 7350a35de9fd4fc20d822e0e427c2a8a1d84256d..06b5cc927c9b2403d3f4e18726e681277f7ca56d 100644 (file)
--- 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 4c9dc1ade7cfb0623d19a967a3ea3d899fe59d1c..6fcfa16261534fdaf3cdb938ca93e233c49b6919 100644 (file)
--- 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 9634bdf2594431058ce5245a3c185813f45a8e28..ecdd10fee728f9fdd88723660a7aeaace7a93522 100644 (file)
--- 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 7912fce1f68d2c59256aef72c2b963e3da829467..bfacae6ad5b2f78260342b2ee15cdc1e59729e6d 100644 (file)
--- 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 c3f5312601c6d373f6aa0d3e0b773a67b44d5ca0..1827881e9aa82d96743837ed04edd987189b56a7 100644 (file)
--- 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 ce169233c1a68c93137691b020a55b16e1ff14b5..c6a1dbf73f1c1e5af5902bcfd0ce0fb31dad81a9 100644 (file)
--- 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 4c4220f238c5aee623ab57c42225138ecc64e685..967d5c9a33b4d6d5f22f9b621b70bc51004233fe 100644 (file)
--- 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 70c4fb44d9a621183a568d5aa6d2be34078f3f79..ccd4b476437f170f83bca278208098d478288220 100644 (file)
--- 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 a1d1b4db611f57f909a3cd30e51a2b29f739bed7..d75b6ae6cf335bd2f10aed4c6e1f73a09be4482a 100644 (file)
--- 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 e6d42f0289ed93fd0b33a21b3280a11bc4e1a8ee..6f70035fedbce23083559e65d9afad24ac596f30 100644 (file)
--- 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 d40450e2985379192e6401d2906d405efc780a61..96ca9d0b32f9966297be3fc34321d52f6b108552 100644 (file)
--- 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 3808fb47ba1b7ad61abf8349eebf50884a2c0177..79dd9e743d945c2b8b6d6852a5c08f80b8f210fa 100755 (executable)
--- 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 fad1a747e66fad93358690d372008907a5fe12df..f12dc0a15c715ad5b3c5402173e2c1427bb30498 100644 (file)
--- 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 42c87f05b9519a8c27e76877acce8f21928ad70f..5489db00ab1643ef03dec630b01f8ca5a88c6d0c 100644 (file)
--- 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 351cf5cde0661e3c707332922a7a1efb8cd32d70..417b7fbed06790d1c41e5bfe06dbec24800a437b 100644 (file)
--- 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 3ac6a4531f236c9900cd4b13c9b0fbdac7476a44..0469f458588de0d09c259f6c9b94250c0f336964 100644 (file)
--- 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 871f79d320b949f4ea951e9ec243eb8db9ed76fa..3011aac10b6e87c32fca68954884f632f71d95bc 100644 (file)
--- 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 d4207caf5bb5396da2d475d7b0f3a2043df8bf0a..5871f73a4a0fbdf91de410651627d4fdbb71bd3b 100644 (file)
--- 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 d67e0a12b9fa0bf70303d52b650f009f9365d3e6..98b1d6428cfff4c441481ec4cd294ae4956d3213 100755 (executable)
--- 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