call( fast-path now supports curry and compose

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

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 ;

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
+[ 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

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>>
     [ ] [

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 ;

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? } ;

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

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
+[ { } ] [ { "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

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