compiler.tree.propagation.call-effect: stronger call( inlining; now can inline 'a...

diff --git a/basis/classes/struct/struct-tests.factor b/basis/classes/struct/struct-tests.factor
index 195664b8b6dbe8d70beb6159161d201e130c69ef..d76013e138ca7ee8308a2db65e1a75ff11cbe8a4 100755 (executable)
--- a/basis/classes/struct/struct-tests.factor
+++ b/basis/classes/struct/struct-tests.factor
@@ -316,6 +316,11 @@ STRUCT: struct-test-optimization
 
 [ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
 
+[ t ] [
+    [ struct-test-optimization <struct> struct-test-optimization <struct> [ x>> ] bi@ ]
+    { x>> } inlined?
+] unit-test
+
 ! Test cloning structs
 STRUCT: clone-test-struct { x int } { y char[3] } ;
 
@@ -340,3 +345,4 @@ STRUCT: struct-that's-a-word { x int } ;
 : struct-that's-a-word ( -- ) "OOPS" throw ;
 
 [ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test
+

diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor
index 09d80e500307f1a69fa36bde645f6804255996dc..dc7fa965db490b56598e0eba39cb84965dba7442 100755 (executable)
--- a/basis/classes/struct/struct.factor
+++ b/basis/classes/struct/struct.factor
@@ -42,11 +42,9 @@ M: struct hashcode*
 : struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
 
 : memory>struct ( ptr class -- struct )
-    [ 1array ] dip slots>tuple ;
-
-\ memory>struct [
-    dup struct-class? [ '[ _ boa ] ] [ drop f ] if
-] 1 define-partial-eval
+    ! This is sub-optimal if the class is not literal, but gets
+    ! optimized down to efficient code if it is.
+    '[ _ boa ] call( ptr -- struct ) ; inline
 
 <PRIVATE
 : (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )

diff --git a/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor b/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
index 0c4bf9040c3b8193100ea59c91dab0073a5ba7b1..79a9f69de5c2a1566f87f4811c8699db77975263 100644 (file)
--- a/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
+++ b/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
@@ -47,9 +47,15 @@ IN: compiler.tree.propagation.call-effect.tests
 [ 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
+[ t ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value (( -- object )) effect= ] unit-test
 [ f ] [ [ dup drop ] final-info first infer-value ] unit-test
 
 ! This should not hang
 [ ] [ [ [ dup call( quot -- ) ] dup call( quot -- ) ] final-info drop ] unit-test
-[ ] [ [ [ dup curry call( quot -- ) ] dup curry call( quot -- ) ] final-info drop ] unit-test
\ No newline at end of file
+[ ] [ [ [ dup curry call( quot -- ) ] dup curry call( quot -- ) ] final-info drop ] unit-test
+
+! This should get inlined, because the parameter to the curry is literal even though
+! [ boa ] by itself doesn't infer
+TUPLE: a-tuple x ;
+
+[ V{ a-tuple } ] [ [ a-tuple '[ _ boa ] call( x -- tuple ) ] final-classes ] unit-test
\ No newline at end of file

diff --git a/basis/compiler/tree/propagation/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor
index cdbeabe532d6b3920bdcd3ac0e8586be2f8c86af..614ceeb59770bf5eb74c0f8b75f41a74b68312da 100644 (file)
--- a/basis/compiler/tree/propagation/call-effect/call-effect.factor
+++ b/basis/compiler/tree/propagation/call-effect/call-effect.factor
@@ -50,12 +50,12 @@ M: curry cached-effect
 M: compose cached-effect
     [ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
 
+: safe-infer ( quot -- effect )
+    [ infer ] [ 2drop +unknown+ ] recover ;
+
 M: quotation cached-effect
     dup cached-effect>>
-    [ ] [
-        [ [ infer ] [ 2drop +unknown+ ] recover dup ] keep
-        (>>cached-effect)
-    ] ?if ;
+    [ ] [ [ safe-infer dup ] keep (>>cached-effect) ] ?if ;
 
 : call-effect-unsafe? ( quot effect -- ? )
     [ cached-effect ] dip
@@ -116,6 +116,29 @@ M: quotation cached-effect
 : execute-effect>quot ( effect -- quot )
     inline-cache new '[ drop _ _ execute-effect-ic ] ;
 
+! Some bookkeeping to make sure that crap like
+! [ dup curry call( quot -- ) ] dup curry call( quot -- ) ]
+! doesn't hang the compiler.
+GENERIC: already-inlined-quot? ( quot -- ? )
+
+M: curry already-inlined-quot? quot>> already-inlined-quot? ;
+
+M: compose already-inlined-quot?
+    [ first>> already-inlined-quot? ]
+    [ second>> already-inlined-quot? ] bi or ;
+
+M: quotation already-inlined-quot? already-inlined? ;
+
+GENERIC: add-quot-to-history ( quot -- )
+
+M: curry add-quot-to-history quot>> add-quot-to-history ;
+
+M: compose add-quot-to-history
+    [ first>> add-quot-to-history ]
+    [ second>> add-quot-to-history ] bi ;
+
+M: quotation add-quot-to-history add-to-history ;
+
 : last2 ( seq -- penultimate ultimate )
     2 tail* first2 ;
 
@@ -129,22 +152,18 @@ ERROR: uninferable ;
     (( -- object )) swap compose-effects ;
 
 : (infer-value) ( value-info -- effect )
-    dup class>> {
-        { \ quotation [
-            literal>> [ uninferable ] unless*
-            dup already-inlined? [ uninferable ] when
-            cached-effect dup +unknown+ = [ uninferable ] when
-        ] }
-        { \ curry [
-            slots>> third (infer-value)
-            remove-effect-input
-        ] }
-        { \ compose [
-            slots>> last2 [ (infer-value) ] bi@
-            compose-effects
-        ] }
-        [ uninferable ]
-    } case ;
+    dup literal?>> [
+        literal>>
+        [ callable? [ uninferable ] unless ]
+        [ already-inlined-quot? [ uninferable ] when ]
+        [ safe-infer dup +unknown+ = [ uninferable ] when ] tri
+    ] [
+        dup class>> {
+            { \ curry [ slots>> third (infer-value) remove-effect-input ] }
+            { \ compose [ slots>> last2 [ (infer-value) ] bi@ compose-effects ] }
+            [ uninferable ]
+        } case
+    ] if ;
 
 : infer-value ( value-info -- effect/f )
     [ (infer-value) ]
@@ -152,17 +171,20 @@ ERROR: uninferable ;
     recover ;
 
 : (value>quot) ( value-info -- quot )
-    dup class>> {
-        { \ quotation [ literal>> dup add-to-history '[ drop @ ] ] }
-        { \ curry [
-            slots>> third (value>quot)
-            '[ [ obj>> ] [ quot>> @ ] bi ]
-        ] }
-        { \ compose [
-            slots>> last2 [ (value>quot) ] bi@
-            '[ [ first>> @ ] [ second>> @ ] bi ]
-        ] }
-    } case ;
+    dup literal?>> [
+        literal>> [ add-quot-to-history ] [ '[ drop @ ] ] bi
+    ] [
+        dup class>> {
+            { \ curry [
+                slots>> third (value>quot)
+                '[ [ obj>> ] [ quot>> @ ] bi ]
+            ] }
+            { \ compose [
+                slots>> last2 [ (value>quot) ] bi@
+                '[ [ first>> @ ] [ second>> @ ] bi ]
+            ] }
+        } case
+    ] if ;
 
 : value>quot ( value-info -- quot: ( code effect -- ) )
     (value>quot) '[ drop @ ] ;

diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index 3836e0f3ba78451045326c50967eed41c914bda6..0b50632e4e0c0bdef5277a2302b3a6dd1f0622aa 100755 (executable)
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@ -97,11 +97,9 @@ SYMBOL: history
 :: inline-word ( #call word -- ? )
     word already-inlined? [ f ] [
         #call word splicing-body [
-            [
-                word add-to-history
-                dup (propagate)
-            ] with-scope
-            #call (>>body) t
+            word add-to-history
+            #call (>>body)
+            #call propagate-body
         ] [ f ] if*
     ] if ;
 
@@ -141,5 +139,7 @@ SYMBOL: history
     #! Note the logic here: if there's a custom inlining hook,
     #! it is permitted to return f, which means that we try the
     #! normal inlining heuristic.
-    dup custom-inlining? [ 2dup inline-custom ] [ f ] if
-    [ 2drop t ] [ (do-inlining) ] if ;
+    [
+        dup custom-inlining? [ 2dup inline-custom ] [ f ] if
+        [ 2drop t ] [ (do-inlining) ] if
+    ] with-scope ;

diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor
index 0a79f47a345adab0b4bddfee2a4dd13381adeb83..da9f306889a0d74748ad4671d69c70e5f7df6053 100755 (executable)
--- a/basis/struct-arrays/struct-arrays-tests.factor
+++ b/basis/struct-arrays/struct-arrays-tests.factor
@@ -1,6 +1,7 @@
 IN: struct-arrays.tests
 USING: classes.struct struct-arrays tools.test kernel math sequences
-alien.syntax alien.c-types destructors libc accessors sequences.private ;
+alien.syntax alien.c-types destructors libc accessors sequences.private
+compiler.tree.debugger ;
 
 STRUCT: test-struct-array
     { x int }
@@ -52,4 +53,10 @@ STRUCT: fixed-string { text char[100] } ;
     ALIEN: 123 4 fixed-string <direct-struct-array> [ (underlying)>> ] { } map-as
 ] unit-test
 
-[ 10 "int" <struct-array> ] must-fail
\ No newline at end of file
+[ 10 "int" <struct-array> ] must-fail
+
+STRUCT: wig { x int } ;
+: <bacon> ( -- wig ) 0 wig <struct-boa> ; inline
+: waterfall ( -- a b ) 1 wig <struct-array> <bacon> swap first x>> ; inline
+
+[ t ] [ [ waterfall ] { x>> } inlined? ] unit-test
\ No newline at end of file