From 47500fad061c35a2666a8e8a793c24aed6f3ed6b Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-122.local>
Date: Tue, 14 Jul 2009 01:12:45 -0500
Subject: [PATCH] call( and execute( inline known quotations/words in the
 propagation pass

---
 .../tree/propagation/call-effect/authors.txt  |  2 +
 .../call-effect/call-effect-tests.factor      | 51 +++++++++++
 .../call-effect/call-effect.factor            | 85 ++++++++++++++++---
 .../known-words/known-words.factor            |  3 +-
 basis/stack-checker/call-effect/authors.txt   |  1 -
 .../call-effect/call-effect-tests.factor      | 16 ----
 .../known-words/known-words.factor            | 10 +++
 basis/stack-checker/stack-checker.factor      |  2 -
 8 files changed, 138 insertions(+), 32 deletions(-)
 create mode 100644 basis/compiler/tree/propagation/call-effect/authors.txt
 create mode 100644 basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
 rename basis/{stack-checker => compiler/tree/propagation}/call-effect/call-effect.factor (59%)
 delete mode 100644 basis/stack-checker/call-effect/authors.txt
 delete mode 100644 basis/stack-checker/call-effect/call-effect-tests.factor

diff --git a/basis/compiler/tree/propagation/call-effect/authors.txt b/basis/compiler/tree/propagation/call-effect/authors.txt
new file mode 100644
index 0000000000..a44f8d7f8d
--- /dev/null
+++ b/basis/compiler/tree/propagation/call-effect/authors.txt
@@ -0,0 +1,2 @@
+Slava Pestov
+Daniel Ehrenberg
diff --git a/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor b/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
new file mode 100644
index 0000000000..5964bcee35
--- /dev/null
+++ b/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
diff --git a/basis/stack-checker/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor
similarity index 59%
rename from basis/stack-checker/call-effect/call-effect.factor
rename to basis/compiler/tree/propagation/call-effect/call-effect.factor
index 12477fdb1d..bc18aa6ec1 100644
--- a/basis/stack-checker/call-effect/call-effect.factor
+++ b/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 ;
-IN: stack-checker.call-effect
+words math stack-checker stack-checker.transforms
+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 )
-    inline-cache new '[ _ call-effect-ic ] ;
-
-\ call-effect [ call-effect>quot ] 0 define-transform
-
-\ call-effect t "no-compile" set-word-prop
+: call-effect>quot ( effect -- quot )
+    inline-cache new '[ drop _ _ call-effect-ic ] ;
 
 : 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
diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index 2f5c166ac5..b3c8026bc4 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/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
diff --git a/basis/stack-checker/call-effect/authors.txt b/basis/stack-checker/call-effect/authors.txt
deleted file mode 100644
index d4f5d6b3ae..0000000000
--- a/basis/stack-checker/call-effect/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
\ No newline at end of file
diff --git a/basis/stack-checker/call-effect/call-effect-tests.factor b/basis/stack-checker/call-effect/call-effect-tests.factor
deleted file mode 100644
index 0ad64cace3..0000000000
--- a/basis/stack-checker/call-effect/call-effect-tests.factor
+++ /dev/null
@@ -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
\ No newline at end of file
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 5bf50dfac1..6959e32452 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/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
diff --git a/basis/stack-checker/stack-checker.factor b/basis/stack-checker/stack-checker.factor
index 759988a61f..fe52357f9e 100644
--- a/basis/stack-checker/stack-checker.factor
+++ b/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
\ No newline at end of file