call( fast-path now supports curry and compose

diff --git a/basis/compiler/tests/call-effect.factor b/basis/compiler/tests/call-effect.factor
new file mode 100644 (file)
index 0000000..407250a
--- /dev/null
+++ b/basis/compiler/tests/call-effect.factor
@@ -0,0 +1,7 @@
+IN: compiler.tests.call-effect
+USING: tools.test combinators generic.single sequences kernel ;
+
+: execute-ic-test ( a b -- c ) execute( a -- c ) ;
+
+! VM type check error
+[ 1 f execute-ic-test ] [ second 3 = ] must-fail-with
\ No newline at end of file

diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index 42c47377e09f4fae910f125f8f9fe01b6e05dede..2a7d4313148a346c01f8c006393b55924b220632 100755 (executable)
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@ -188,9 +188,7 @@ SYMBOL: history
     { curry compose } memq? ;
 
 : never-inline-word? ( word -- ? )
-    [ deferred? ]
-    [ "default" word-prop ]
-    [ { call execute } memq? ] tri or or ;
+    [ deferred? ] [ "default" word-prop ] [ \ call eq? ] tri or or ;
 
 : custom-inlining? ( word -- ? )
     "custom-inlining" word-prop ;

diff --git a/basis/stack-checker/call-effect/call-effect-tests.factor b/basis/stack-checker/call-effect/call-effect-tests.factor
index e5c0f23b30f32ddb30160ed56690671aa3357521..b222cbbcf75ce374c6133953f1e6e20199133209 100644 (file)
--- a/basis/stack-checker/call-effect/call-effect-tests.factor
+++ b/basis/stack-checker/call-effect/call-effect-tests.factor
@@ -1,7 +1,16 @@
-USING: stack-checker.call-effect tools.test math kernel ;
+USING: stack-checker.call-effect tools.test math kernel math effects ;
 IN: stack-checker.call-effect.tests
 
 [ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
 [ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
 [ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
-[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
\ No newline at end of file
+[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
+
+[ t ] [ [ + ] cached-effect (( a b -- c )) effect= ] unit-test
+[ t ] [ 5 [ + ] curry cached-effect (( a -- c )) effect= ] unit-test
+[ t ] [ 5 [ ] curry cached-effect (( -- c )) effect= ] unit-test
+[ t ] [ [ dup ] [ drop ] compose cached-effect (( a -- b )) effect= ] unit-test
+[ t ] [ [ drop ] [ dup ] compose cached-effect (( a b -- c d )) effect= ] unit-test
+[ t ] [ [ 2drop ] [ dup ] compose cached-effect (( a b c -- d e )) effect= ] unit-test
+[ t ] [ [ 1 2 3 ] [ 2drop ] compose cached-effect (( -- a )) effect= ] unit-test
+[ t ] [ [ 1 2 ] [ 3drop ] compose cached-effect (( a -- )) effect= ] unit-test
\ No newline at end of file

diff --git a/basis/stack-checker/call-effect/call-effect.factor b/basis/stack-checker/call-effect/call-effect.factor
index daeecc3ad5c345476890a6985b3c702d5fd31058..4adc5952fdfb7e82be71deeeb2635cc748be529d 100644 (file)
--- a/basis/stack-checker/call-effect/call-effect.factor
+++ b/basis/stack-checker/call-effect/call-effect.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators combinators.private effects fry
 kernel kernel.private make sequences continuations quotations
-stack-checker stack-checker.transforms words ;
+stack-checker stack-checker.transforms words math ;
 IN: stack-checker.call-effect
 
 ! call( and execute( have complex expansions.
@@ -18,14 +18,36 @@ IN: stack-checker.call-effect
 
 TUPLE: inline-cache value ;
 
-: cache-hit? ( word/quot ic -- ? ) value>> eq? ; inline
+: cache-hit? ( word/quot ic -- ? )
+    [ value>> ] [ value>> eq? ] bi and ; inline
 
-SYMBOL: +unknown+
+SINGLETON: +unknown+
 
 GENERIC: cached-effect ( quot -- effect )
 
 M: object cached-effect drop +unknown+ ;
 
+GENERIC: curry-effect ( effect -- effect' )
+
+M: +unknown+ curry-effect ;
+
+M: effect curry-effect
+    [ in>> length ] [ out>> length ] [ terminated?>> ] tri
+    pick 0 = [ [ 1+ ] dip ] [ [ 1- ] 2dip ] if
+    effect boa ;
+
+M: curry cached-effect
+    quot>> cached-effect curry-effect ;
+
+: compose-effects* ( effect1 effect2 -- effect' )
+    {
+        { [ 2dup [ effect? ] both? ] [ compose-effects ] }
+        { [ 2dup [ +unknown+ eq? ] either? ] [ 2drop +unknown+ ] }
+    } cond ;
+
+M: compose cached-effect
+    [ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
+
 M: quotation cached-effect
     dup cached-effect>>
     [ ] [

diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index d7acf7716242563d7563b5a6962beb9d379f2b83..4a9ff93179c21247986f0a5f8c3a699b6a325922 100644 (file)
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -147,7 +147,7 @@ M: object infer-call*
     apply-word/effect ;
 
 : infer-execute-effect-unsafe ( -- )
-    \ execute infer-effect-unsafe ;
+    \ (execute) infer-effect-unsafe ;
 
 : infer-call-effect-unsafe ( -- )
     \ call infer-effect-unsafe ;

diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor
index 243221ccf0c943fc60eafa9b55185a52217beb39..7d18482bff8edc07451a51ec3fbc68f10546cf7f 100644 (file)
--- a/basis/stack-checker/stack-checker-docs.factor
+++ b/basis/stack-checker/stack-checker-docs.factor
@@ -102,6 +102,7 @@ ARTICLE: "tools.inference" "Stack effect tools"
 "Comparing effects:"
 { $subsection effect-height }
 { $subsection effect<= }
+{ $subsection effect= }
 "The class of stack effects:"
 { $subsection effect }
 { $subsection effect? } ;

diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor
index 495aeb39c141d1a601e3b7b36f97f63a5eda27a5..38b8ab4dad2986985777795cdb52f4dc9891e200 100644 (file)
--- a/core/effects/effects-docs.factor
+++ b/core/effects/effects-docs.factor
@@ -42,8 +42,15 @@ HELP: effect-height
 { $description "Outputs the number of objects added to the data stack by the stack effect. This will be negative if the stack effect only removes objects from the stack." } ;
 
 HELP: effect<=
-{ $values { "eff1" effect } { "eff2" effect } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "eff1" } " is substitutable for " { $snippet "eff2" } ". What this means is that both stack effects change the stack height by the same amount, the first takes a smaller or equal number of inputs as the second, and either both or neither one terminate execution by throwing an error." } ;
+{ $values { "effect1" effect } { "effect2" effect } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "effect1" } " is substitutable for " { $snippet "effect2" } ". What this means is that both stack effects change the stack height by the same amount, the first takes a smaller or equal number of inputs as the second, and either both or neither one terminate execution by throwing an error." } ;
+
+HELP: effect=
+{ $values { "effect1" effect } { "effect2" effect } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "effect1" } " and " { $snippet "effect2" } " represent the same stack transformation, without looking parameter names." }
+{ $examples
+  { $example "USING: effects prettyprint ;" "(( a -- b )) (( x -- y )) effect= ." "t" }
+} ;
 
 HELP: effect>string
 { $values { "obj" object } { "str" string } }

diff --git a/core/effects/effects-tests.factor b/core/effects/effects-tests.factor
index 316add54c0bf4b37912bd933becf9f77ea6f9de9..3eb92738595188d03b661e890ee1829df316e6b8 100644 (file)
--- a/core/effects/effects-tests.factor
+++ b/core/effects/effects-tests.factor
@@ -18,4 +18,8 @@ USING: effects tools.test prettyprint accessors sequences ;
 
 [ { "x" "y" } ] [ { "y" "x" } (( a b -- b a )) shuffle ] unit-test
 [ { "y" "x" "y" } ] [ { "y" "x" } (( a b -- a b a )) shuffle ] unit-test
-[ { } ] [ { "y" "x" } (( a b -- )) shuffle ] unit-test
\ No newline at end of file
+[ { } ] [ { "y" "x" } (( a b -- )) shuffle ] unit-test
+
+[ t ] [ (( -- )) (( -- )) compose-effects (( -- )) effect= ] unit-test
+[ t ] [ (( -- * )) (( -- )) compose-effects (( -- * )) effect= ] unit-test
+[ t ] [ (( -- )) (( -- * )) compose-effects (( -- * )) effect= ] unit-test
\ No newline at end of file

diff --git a/core/effects/effects.factor b/core/effects/effects.factor
index 142b9120a8d5c3692846013348dac3641b6c7904..cab1e531b796200781c3757fa57cc9fafacdadf2 100644 (file)
--- a/core/effects/effects.factor
+++ b/core/effects/effects.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.parser namespaces make sequences strings
+USING: kernel math math.parser math.order namespaces make sequences strings
 words assocs combinators accessors arrays ;
 IN: effects
 
@@ -13,7 +13,7 @@ TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ;
 : effect-height ( effect -- n )
     [ out>> length ] [ in>> length ] bi - ; inline
 
-: effect<= ( eff1 eff2 -- ? )
+: effect<= ( effect1 effect2 -- ? )
     {
         { [ over terminated?>> ] [ t ] }
         { [ dup terminated?>> ] [ f ] }
@@ -22,6 +22,12 @@ TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ;
         [ t ]
     } cond 2nip ; inline
 
+: effect= ( effect1 effect2 -- ? )
+    [ [ in>> length ] bi@ = ]
+    [ [ out>> length ] bi@ = ]
+    [ [ terminated?>> ] bi@ = ]
+    2tri and and ;
+
 GENERIC: effect>string ( obj -- str )
 M: string effect>string ;
 M: object effect>string drop "object" ;
@@ -66,3 +72,13 @@ M: effect clone
 
 : add-effect-input ( effect -- effect' )
     [ in>> "obj" suffix ] [ out>> ] [ terminated?>> ] tri effect boa ;
+
+: compose-effects ( effect1 effect2 -- effect' )
+    over terminated?>> [
+        drop
+    ] [
+        [ [ [ in>> length ] [ out>> length ] bi ] [ in>> length ] bi* swap [-] + ]
+        [ [ out>> length ] [ [ in>> length ] [ out>> length ] bi ] bi* [ [-] ] dip + ]
+        [ nip terminated?>> ] 2tri
+        effect boa
+    ] if ; inline