compiler.tree.propagation.call-effect: stronger call( inlining; now can inline 'a [ b ] curry call(' where 'a' is literal, [ b ] doesn't infer, but [ a b ] does infer. This simplifies classes.struct:memory>struct

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
+

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 ;
+    ! This is sub-optimal if the class is not literal, but gets
-
+    ! optimized down to efficient code if it is.
-\ memory>struct [
+    '[ _ boa ] call( ptr -- struct ) ; inline
-    dup struct-class? [ '[ _ boa ] ] [ drop f ] if
-] 1 define-partial-eval
 
 <PRIVATE
 : (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )

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

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>>
-    [ ] [
+    [ ] [ [ safe-infer dup ] keep (>>cached-effect) ] ?if ;
-        [ [ infer ] [ 2drop +unknown+ ] recover 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>> {
+    dup literal?>> [
-        { \ quotation [
+        literal>>
-            literal>> [ uninferable ] unless*
+        [ callable? [ uninferable ] unless ]
-            dup already-inlined? [ uninferable ] when
+        [ already-inlined-quot? [ uninferable ] when ]
-            cached-effect dup +unknown+ = [ uninferable ] when
+        [ safe-infer dup +unknown+ = [ uninferable ] when ] tri
-        ] }
+    ] [
-        { \ curry [
+        dup class>> {
-            slots>> third (infer-value)
+            { \ curry [ slots>> third (infer-value) remove-effect-input ] }
-            remove-effect-input
+            { \ compose [ slots>> last2 [ (infer-value) ] bi@ compose-effects ] }
-        ] }
+            [ uninferable ]
-        { \ compose [
+        } case
-            slots>> last2 [ (infer-value) ] bi@
+    ] if ;
-            compose-effects
-        ] }
-        [ uninferable ]
-    } case ;
 
 : infer-value ( value-info -- effect/f )
     [ (infer-value) ]
@@ -152,17 +171,20 @@ ERROR: uninferable ;
     recover ;
 
 : (value>quot) ( value-info -- quot )
-    dup class>> {
+    dup literal?>> [
-        { \ quotation [ literal>> dup add-to-history '[ drop @ ] ] }
+        literal>> [ add-quot-to-history ] [ '[ drop @ ] ] bi
-        { \ curry [
+    ] [
-            slots>> third (value>quot)
+        dup class>> {
-            '[ [ obj>> ] [ quot>> @ ] bi ]
+            { \ curry [
-        ] }
+                slots>> third (value>quot)
-        { \ compose [
+                '[ [ obj>> ] [ quot>> @ ] bi ]
-            slots>> last2 [ (value>quot) ] bi@
+            ] }
-            '[ [ first>> @ ] [ second>> @ ] bi ]
+            { \ compose [
-        ] }
+                slots>> last2 [ (value>quot) ] bi@
-    } case ;
+                '[ [ first>> @ ] [ second>> @ ] bi ]
+            ] }
+        } case
+    ] if ;
 
 : value>quot ( value-info -- quot: ( code effect -- ) )
     (value>quot) '[ drop @ ] ;

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
-                word add-to-history
+            #call (>>body)
-                dup (propagate)
+            #call propagate-body
-            ] with-scope
-            #call (>>body) t
         ] [ 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 ;

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 }
@@ -53,3 +54,9 @@ STRUCT: fixed-string { text char[100] } ;
 ] unit-test
 
 [ 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