Fixing some bugs, tweaking optimizer inlining

core/generic/generic.factor

@@ -82,10 +82,19 @@ M: method-body stack-effect
     [ <method-word> ] 3keep f \ method construct-boa
     dup method-word over "method" set-word-prop ;
 
+: redefine-method ( quot method -- )
+    2dup set-method-def
+    method-word swap define ;
+
 : define-method ( quot class generic -- )
     >r bootstrap-word r>
-    [ <method> ] 2keep
+    2dup method dup [
-    [ set-at ] with-methods ;
+        2nip redefine-method
+    ] [
+        drop
+        [ <method> ] 2keep
+        [ set-at ] with-methods
+    ] if ;
 
 : define-default-method ( generic combination -- )
     dupd make-default-method object bootstrap-word pick <method>

core/optimizer/inlining/inlining.factor

@@ -6,62 +6,38 @@ math namespaces sequences vectors words quotations hashtables
 combinators classes generic.math continuations optimizer.def-use
 optimizer.backend generic.standard optimizer.specializers
 optimizer.def-use optimizer.pattern-match generic.standard
-optimizer.control ;
+optimizer.control kernel.private ;
 IN: optimizer.inlining
 
-GENERIC: remember-method* ( method-spec node -- )
+: remember-inlining ( node history -- )
+    [ swap set-node-history ] curry each-node ;
 
-M: #call remember-method*
+: inlining-quot ( node quot -- node )
-    [ node-history ?push ] keep set-node-history ;
-
-M: node remember-method*
-    2drop ;
-
-: remember-method ( method-spec node -- )
-    swap dup second +inlined+ depends-on
-    [ swap remember-method* ] curry each-node ;
-
-: (splice-method) ( #call method-spec quot -- node )
-    #! Must remember the method before splicing in, otherwise
-    #! the rest of the IR will also remember the method
-    pick node-in-d dataflow-with
-    [ remember-method ] keep
-    [ swap infer-classes/node ] 2keep
-    [ splice-node ] keep ;
-
-: splice-quot ( #call quot -- node )
     over node-in-d dataflow-with
-    [ swap infer-classes/node ] 2keep
+    dup rot infer-classes/node ;
-    [ splice-node ] keep ;
 
-! #call
+: splice-quot ( #call quot history -- node )
-: splice-method ( #call method-spec/t quot/t -- node/t )
+    #! Must add history *before* splicing in, otherwise
-    #! t indicates failure
+    #! the rest of the IR will also remember the history
-    {
+    pick node-history append
-        { [ dup t eq? ] [ 3drop t ] }
+    >r dupd inlining-quot dup r> remember-inlining
-        { [ 2over swap node-history member? ] [ 3drop t ] }
+    tuck splice-node ;
-        { [ t ] [ (splice-method) ] }
-    } cond ;
-
-! Single dispatch method inlining optimization
-: already-inlined? ( node -- ? )
-    #! Was this node inlined from definition of 'word'?
-    dup node-param swap node-history memq? ;
-
-: specific-method ( class word -- class ) order min-class ;
-
-: node-class# ( node n -- class )
-    over node-in-d <reversed> ?nth node-class ;
-
-: dispatching-class ( node word -- class )
-    [ dispatch# node-class# ] keep specific-method ;
 
 ! A heuristic to avoid excessive inlining
 DEFER: (flat-length)
 
 : word-flat-length ( word -- n )
-    dup get over inline? not or
+    {
-    [ drop 1 ] [ dup dup set word-def (flat-length) ] if ;
+        ! heuristic: { ... } declare comes up in method bodies
+        ! and we don't care about it
+        { [ dup \ declare eq? ] [ drop -2 ] }
+        ! recursive
+        { [ dup get ] [ drop 1 ] }
+        ! not inline
+        { [ dup inline? not ] [ drop 1 ] }
+        ! inline
+        { [ t ] [ dup dup set word-def (flat-length) ] }
+    } cond ;
 
 : (flat-length) ( seq -- n )
     [
@@ -76,32 +52,29 @@ DEFER: (flat-length)
 : flat-length ( seq -- n )
     [ word-def (flat-length) ] with-scope ;
 
-: will-inline-method ( node word -- method-spec/t quot/t )
+! Single dispatch method inlining optimization
-    #! t indicates failure
+: specific-method ( class word -- class ) order min-class ;
-    tuck dispatching-class dup [
+
-        swap [ 2array ] 2keep
+: node-class# ( node n -- class )
-        method method-word
+    over node-in-d <reversed> ?nth node-class ;
-        dup flat-length 10 >=
+
-        [ 1quotation ] [ word-def ] if
+: dispatching-class ( node word -- class )
-    ] [
+    [ dispatch# node-class# ] keep specific-method ;
-        2drop t t
-    ] if ;
 
 : inline-standard-method ( node word -- node )
-    dupd will-inline-method splice-method ;
+    2dup dispatching-class dup [
+        swap method method-word 1quotation f splice-quot
+    ] [
+        3drop t
+    ] if ;
 
 ! Partial dispatch of math-generic words
 : math-both-known? ( word left right -- ? )
     math-class-max swap specific-method ;
 
-: will-inline-math-method ( word left right -- method-spec/t quot/t )
-    #! t indicates failure
-    3dup math-both-known?
-    [ [ 3array ] 3keep math-method ] [ 3drop t t ] if ;
-
 : inline-math-method ( #call word -- node )
-    over node-input-classes first2
+    over node-input-classes first2 3dup math-both-known?
-    will-inline-math-method splice-method ;
+    [ math-method f splice-quot ] [ 2drop 2drop t ] if ;
 
 : inline-method ( #call -- node )
     dup node-param {
@@ -131,7 +104,7 @@ DEFER: (flat-length)
 
 : inline-literals ( node literals -- node )
     #! Make #shuffle -> #push -> #return -> successor
-    dupd literal-quot splice-quot ;
+    dupd literal-quot f splice-quot ;
 
 : evaluate-predicate ( #call -- ? )
     dup node-param "predicating" word-prop >r
@@ -196,7 +169,7 @@ DEFER: (flat-length)
     nip dup [ second ] when ;
 
 : apply-identities ( node -- node/f )
-    dup find-identity dup [ splice-quot ] [ 2drop f ] if ;
+    dup find-identity dup [ f splice-quot ] [ 2drop f ] if ;
 
 : optimistic-inline? ( #call -- ? )
     dup node-param "specializer" word-prop dup [
@@ -206,13 +179,20 @@ DEFER: (flat-length)
         2drop f
     ] if ;
 
+: splice-word-def ( #call word -- node )
+    dup +inlined+ depends-on
+    dup word-def swap 1array splice-quot ;
+
 : optimistic-inline ( #call -- node )
-    dup node-param dup +inlined+ depends-on
+    dup node-param over node-history memq? [
-    word-def splice-quot ;
+        drop t
+    ] [
+        dup node-param splice-word-def
+    ] if ;
 
 : method-body-inline? ( #call -- ? )
     node-param dup method-body?
-    [ flat-length 8 <= ] [ drop f ] if ;
+    [ flat-length 10 <= ] [ drop f ] if ;
 
 M: #call optimize-node*
     {

core/optimizer/known-words/known-words.factor

@@ -40,7 +40,7 @@ optimizer.inlining float-arrays sequences.private combinators ;
 : flip-branches ( #call -- #if )
     #! If a not is followed by an #if, flip branches and
     #! remove the not.
-    dup sole-consumer (flip-branches) [ ] splice-quot ;
+    dup sole-consumer (flip-branches) [ ] f splice-quot ;
 
 \ not {
     { [ dup flip-branches? ] [ flip-branches ] }
@@ -63,7 +63,7 @@ optimizer.inlining float-arrays sequences.private combinators ;
     [ [ t ] ] { } map>assoc [ drop f ] add [ nip case ] curry ;
 
 : expand-member ( #call -- )
-    dup node-in-d peek value-literal member-quot splice-quot ;
+    dup node-in-d peek value-literal member-quot f splice-quot ;
 
 \ member? {
     { [ dup literal-member? ] [ expand-member ] }

core/optimizer/math/math.factor

@@ -366,7 +366,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
 } [
     [
         [ dup remove-overflow-check? ] ,
-        [ splice-quot ] curry ,
+        [ f splice-quot ] curry ,
     ] { } make 1array define-optimizers
 ] assoc-each
 
@@ -436,7 +436,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
             dup remove-overflow-check?
             over coereced-to-fixnum? or
         ] ,
-        [ splice-quot ] curry ,
+        [ f splice-quot ] curry ,
     ] { } make 1array define-optimizers
 ] assoc-each
 
@@ -461,6 +461,6 @@ most-negative-fixnum most-positive-fixnum [a,b]
 \ fixnum-shift {
     {
         [ dup fixnum-shift-fast? ]
-        [ [ fixnum-shift-fast ] splice-quot ]
+        [ [ fixnum-shift-fast ] f splice-quot ]
     }
 } define-optimizers

core/optimizer/optimizer-tests.factor

@@ -2,7 +2,7 @@ USING: arrays compiler generic hashtables inference kernel
 kernel.private math optimizer prettyprint sequences sbufs
 strings tools.test vectors words sequences.private quotations
 optimizer.backend classes inference.dataflow tuples.private
-continuations growable optimizer.inlining namespaces ;
+continuations growable optimizer.inlining namespaces hints ;
 IN: temporary
 
 [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [
@@ -351,3 +351,28 @@ M: integer generic-inline-test ;
     \ generic-inline-test-1 word-def dataflow
     [ optimize-1 , optimize-1 , drop ] { } make
 ] unit-test
+
+! Forgot a recursive inline check
+: recursive-inline-hang ( a -- a )
+    dup array? [ recursive-inline-hang ] when ;
+
+HINTS: recursive-inline-hang array ;
+
+: recursive-inline-hang-1
+    { } recursive-inline-hang ;
+
+[ t ] [ \ recursive-inline-hang-1 compiled? ] unit-test
+
+DEFER: recursive-inline-hang-3
+
+: recursive-inline-hang-2 ( a -- a )
+    dup array? [ recursive-inline-hang-3 ] when ;
+
+HINTS: recursive-inline-hang-2 array ;
+
+: recursive-inline-hang-3 ( a -- a )
+    dup array? [ recursive-inline-hang-2 ] when ;
+
+HINTS: recursive-inline-hang-3 array ;
+
+