call( and execute( inline known quotations/words in the propagation pass

basis/compiler/tree/propagation/call-effect/authors.txt

@@ -0,0 +1,2 @@
+Slava Pestov
+Daniel Ehrenberg

basis/compiler/tree/propagation/call-effect/call-effect-tests.factor

@@ -0,0 +1,51 @@
+! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.tree.propagation.call-effect tools.test fry math effects kernel
+compiler.tree.builder compiler.tree.optimizer compiler.tree.debugger sequences ;
+IN: compiler.tree.propagation.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
+
+[ 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
+
+: optimized-quot ( quot -- quot' )
+    build-tree optimize-tree nodes>quot ;
+
+: compiled-call2 ( a quot: ( a -- b ) -- b )
+    call( a -- b ) ;
+
+: compiled-execute2 ( a b word: ( a b -- c ) -- c )
+    execute( a b -- c ) ;
+
+[ [ 3 ] ] [ [ 1 2 \ + execute( a b -- c ) ] optimized-quot ] unit-test
+[ [ 3 ] ] [ [ 1 2 [ + ] call( a b -- c ) ] optimized-quot ] unit-test
+[ [ 3 ] ] [ [ 1 2 '[ _ + ] call( a -- b ) ] optimized-quot ] unit-test
+[ [ 3 ] ] [ [ 1 2 '[ _ ] [ + ] compose call( a -- b ) ] optimized-quot ] unit-test
+
+[ 1 2 { [ + ] } first compiled-call2 ] must-fail
+[ 3 ] [ 1 2 { + } first compiled-execute2 ] unit-test
+[ 3 ] [ 1 2 '[ _ + ] compiled-call2 ] unit-test
+[ 3 ] [ 1 2 '[ _ ] [ + ] compose compiled-call2 ] unit-test
+[ 3 ] [ 1 2 \ + compiled-execute2 ] unit-test
+
+[ 3 ] [ 1 2 { [ + ] } first call( a b -- c ) ] unit-test
+[ 3 ] [ 1 2 { + } first execute( a b -- c ) ] unit-test
+[ 3 ] [ 1 2 '[ _ + ] call( a -- b ) ] unit-test
+[ 3 ] [ 1 2 '[ _ ] [ + ] compose call( a -- b ) ] unit-test
+
+[ t ] [ [ 2 '[ _ ] [ + ] compose ] final-info first infer-value (( object -- object )) effect= ] unit-test
+[ t ] [ [ 2 '[ _ ] 1 '[ _ + ] compose ] final-info first infer-value (( -- object )) effect= ] unit-test
+[ t ] [ [ 2 '[ _ + ] ] final-info first infer-value (( object -- object )) effect= ] unit-test
+[ f ] [ [ [ [ ] [ 1 ] if ] ] final-info first infer-value ] unit-test
+[ f ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value ] unit-test
+[ f ] [ [ dup drop ] final-info first infer-value ] unit-test

basis/compiler/tree/propagation/call-effect/call-effect.factor

@@ -1,9 +1,10 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
 ! 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 math ;
+words math stack-checker stack-checker.transforms
-IN: stack-checker.call-effect
+compiler.tree.propagation.info slots.private ;
+IN: compiler.tree.propagation.call-effect
 
 ! call( and execute( have complex expansions.
 
@@ -90,12 +91,8 @@ M: quotation cached-effect
     [ call-effect-fast ]
     if ; inline
 
-: call-effect>quot ( -- quot )
+: call-effect>quot ( effect -- quot )
-    inline-cache new '[ _ call-effect-ic ] ;
+    inline-cache new '[ drop _ _ call-effect-ic ] ;
-
-\ call-effect [ call-effect>quot ] 0 define-transform
-
-\ call-effect t "no-compile" set-word-prop
 
 : execute-effect-slow ( word effect -- )
     [ '[ _ execute ] ] dip call-effect-slow ; inline
@@ -116,8 +113,72 @@ M: quotation cached-effect
     if ; inline
 
 : execute-effect>quot ( effect -- quot )
-    inline-cache new '[ _ _ execute-effect-ic ] ;
+    inline-cache new '[ drop _ _ execute-effect-ic ] ;
 
-\ execute-effect [ execute-effect>quot ] 1 define-transform
+: last2 ( seq -- penultimate ultimate )
+    2 tail* first2 ;
 
-\ execute-effect t "no-compile" set-word-prop
+: top-two ( #call -- effect value )
+    in-d>> last2 [ value-info ] bi@
+    literal>> swap ;
+
+ERROR: uninferable ;
+
+: remove-effect-input ( effect -- effect' )
+    (( -- object )) swap compose-effects ;
+
+: (infer-value) ( value-info -- effect )
+    dup class>> {
+        { \ quotation [
+            literal>> [ uninferable ] unless* cached-effect
+            dup +unknown+ = [ uninferable ] when
+        ] }
+        { \ curry [
+            slots>> third (infer-value)
+            remove-effect-input
+        ] }
+        { \ compose [
+            slots>> last2 [ (infer-value) ] bi@
+            compose-effects
+        ] }
+        [ uninferable ]
+    } case ;
+
+: infer-value ( value-info -- effect/f )
+    [ (infer-value) ]
+    [ dup uninferable? [ 2drop f ] [ rethrow ] if ]
+    recover ;
+
+: (value>quot) ( value-info -- quot )
+    dup class>> {
+        { \ quotation [ literal>> '[ drop @ ] ] }
+        { \ curry [
+            slots>> third (value>quot)
+            '[ [ obj>> ] [ quot>> @ ] bi ]
+        ] }
+        { \ compose [
+            slots>> last2 [ (value>quot) ] bi@
+            '[ [ first>> @ ] [ second>> @ ] bi ]
+        ] }
+    } case ;
+
+: value>quot ( value-info -- quot: ( code effect -- ) )
+    (value>quot) '[ drop @ ] ;
+
+: call-inlining ( #call -- quot/f )
+    top-two dup infer-value [
+        pick effect<=
+        [ nip value>quot ]
+        [ drop call-effect>quot ] if
+    ] [ drop call-effect>quot ] if* ;
+
+\ call-effect [ call-inlining ] "custom-inlining" set-word-prop
+
+: execute-inlining ( #call -- quot/f )
+    top-two >literal< [
+        2dup swap execute-effect-unsafe?
+        [ nip '[ 2drop _ execute ] ]
+        [ drop execute-effect>quot ] if
+    ] [ drop execute-effect>quot ] if ;
+
+\ execute-effect [ execute-inlining ] "custom-inlining" set-word-prop

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -13,7 +13,8 @@ compiler.tree.propagation.info
 compiler.tree.propagation.nodes
 compiler.tree.propagation.slots
 compiler.tree.propagation.simple
-compiler.tree.propagation.constraints ;
+compiler.tree.propagation.constraints
+compiler.tree.propagation.call-effect ;
 IN: compiler.tree.propagation.known-words
 
 \ fixnum

basis/stack-checker/call-effect/authors.txt

@@ -1 +0,0 @@
-Slava Pestov

basis/stack-checker/call-effect/call-effect-tests.factor

@@ -1,16 +0,0 @@
-USING: stack-checker.call-effect tools.test 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
-
-[ 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/known-words/known-words.factor

@@ -205,6 +205,16 @@ M: object infer-call*
 
 \ drop-locals [ infer-drop-locals ] "special" set-word-prop
 
+: infer-call-effect ( word -- )
+    1 ensure-d first literal value>>
+    add-effect-input add-effect-input
+    apply-word/effect ;
+
+{ call-effect execute-effect } [
+    dup t "no-compile" set-word-prop
+    dup '[ _ infer-call-effect ] "special" set-word-prop
+] each
+
 \ do-primitive [ unknown-primitive-error ] "special" set-word-prop
 
 \ if [ infer-if ] "special" set-word-prop

basis/stack-checker/stack-checker.factor

@@ -15,5 +15,3 @@ M: callable infer ( quot -- effect )
 : infer. ( quot -- )
     #! Safe to call from inference transforms.
     infer effect>string print ;
-
-"stack-checker.call-effect" require