Refactoring recursive-state alist; now its a mapping from words to local state triples, reduces searching by a bit

basis/compiler/tree/builder/builder.factor

@@ -12,12 +12,13 @@ IN: compiler.tree.builder
 
 : build-tree ( quot -- nodes )
     #! Not safe to call from inference transforms.
-    [ f infer-quot ] with-tree-builder nip ;
+    [ f initial-recursive-state infer-quot ] with-tree-builder nip ;
 
 : build-tree-with ( in-stack quot -- nodes out-stack )
     #! Not safe to call from inference transforms.
     [
-        [ >vector meta-d set ] [ f infer-quot ] bi*
+        [ >vector meta-d set ]
+        [ f initial-recursive-state infer-quot ] bi*
     ] with-tree-builder nip
     unclip-last in-d>> ;
 
@@ -32,10 +33,10 @@ IN: compiler.tree.builder
     dup
     [ "inline" word-prop ]
     [ "recursive" word-prop ] bi and [
-        1quotation f infer-quot
+        1quotation f initial-recursive-state infer-quot
     ] [
-        [ specialized-def ]
+        [ specialized-def ] [ initial-recursive-state ] bi
-        [ dup 2array 1array ] bi infer-quot
+        infer-quot
     ] if ;
 
 : check-cannot-infer ( word -- )

basis/stack-checker/backend/backend.factor

@@ -82,9 +82,6 @@ M: object apply-object push-literal ;
         infer-quot-here
     ] dip recursive-state set ;
 
-: infer-quot-recursive ( quot word label -- )
-    2array recursive-state get swap prefix infer-quot ;
-
 : time-bomb ( error -- )
     '[ _ throw ] infer-quot-here ;
 
@@ -97,7 +94,7 @@ M: object apply-object push-literal ;
     ] [
         dup value>> callable? [
             [ value>> ]
-            [ [ recursion>> ] keep f 2array prefix ]
+            [ [ recursion>> ] keep add-local-quotation ]
             bi infer-quot
         ] [
             drop bad-call
@@ -126,6 +123,9 @@ M: object apply-object push-literal ;
         terminated?>> [ terminate ] when
     ] 2bi ; inline
 
+: infer-word-def ( word -- )
+    [ def>> ] [ add-recursive-state ] bi infer-quot ;
+
 : check->r ( -- )
     meta-r get empty? terminated? get or
     [ \ too-many->r inference-error ] unless ;
@@ -174,7 +174,7 @@ M: object apply-object push-literal ;
             stack-visitor off
             dependencies off
             generic-dependencies off
-            [ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ]
+            [ infer-word-def end-infer ]
             [ finish-word current-effect ]
             bi
         ] with-scope

basis/stack-checker/errors/errors.factor

@@ -2,11 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel generic sequences prettyprint io words arrays
 summary effects debugger assocs accessors namespaces
-compiler.errors ;
+compiler.errors stack-checker.state ;
 IN: stack-checker.errors
 
-SYMBOL: recursive-state
-
 TUPLE: inference-error error type rstate ;
 
 M: inference-error compiler-error-type type>> ;
@@ -35,6 +33,8 @@ TUPLE: literal-expected ;
 M: literal-expected summary
     drop "Literal value expected" ;
 
+M: object (literal) \ literal-expected inference-warning ;
+
 TUPLE: unbalanced-branches-error branches quots ;
 
 : unbalanced-branches-error ( branches quots -- * )

basis/stack-checker/inlining/inlining.factor

@@ -14,8 +14,8 @@ IN: stack-checker.inlining
 ! Code to handle inline words. Much of the complexity stems from
 ! having to handle recursive inline words.
 
-: (inline-word) ( word label -- )
+: infer-inline-word-def ( word label -- )
-    [ [ def>> ] keep ] dip infer-quot-recursive ;
+    [ drop def>> ] [ add-local-recursive-state ] 2bi infer-quot ;
 
 TUPLE: inline-recursive < identity-tuple
 id
@@ -88,7 +88,7 @@ SYMBOL: enter-out
         nest-visitor
 
         dup <inline-recursive>
-        [ dup emit-enter-recursive (inline-word) ]
+        [ dup emit-enter-recursive infer-inline-word-def ]
         [ end-recursive-word ]
         [ nip ]
         2tri
@@ -133,20 +133,23 @@ SYMBOL: enter-out
     object <repetition> '[ _ prepend ] bi@
     <effect> ;
 
-: call-recursive-inline-word ( word -- )
+: call-recursive-inline-word ( word label -- )
-    dup "recursive" word-prop [
+    over "recursive" word-prop [
-        [ required-stack-effect adjust-stack-effect ] [ ] [ recursive-label ] tri
+        [ required-stack-effect adjust-stack-effect ] dip
-        [ 2nip check-call ] [ nip '[ _ #call-recursive, ] consume/produce ] 3bi
+        [ check-call ] [ '[ _ #call-recursive, ] consume/produce ] bi
-    ] [ undeclared-recursion-error inference-error ] if ;
+    ] [ drop undeclared-recursion-error inference-error ] if ;
 
 : inline-word ( word -- )
     [ inlined-dependency depends-on ]
     [
-        {
+        dup inline-recursive-label [
-            { [ dup inline-recursive-label ] [ call-recursive-inline-word ] }
+            call-recursive-inline-word
-            { [ dup "recursive" word-prop ] [ inline-recursive-word ] }
+        ] [
-            [ dup (inline-word) ]
+            dup "recursive" word-prop
-        } cond
+            [ inline-recursive-word ]
+            [ dup infer-inline-word-def ]
+            if
+        ] if*
     ] bi ;
 
 M: word apply-object

basis/stack-checker/known-words/known-words.factor

@@ -195,7 +195,7 @@ do-primitive alien-invoke alien-indirect alien-callback
         { [ dup local? ] [ infer-local-reader ] }
         { [ dup local-reader? ] [ infer-local-reader ] }
         { [ dup local-writer? ] [ infer-local-writer ] }
-        { [ dup recursive-label ] [ call-recursive-word ] }
+        { [ dup recursive-word? ] [ call-recursive-word ] }
         [ dup infer-word apply-word/effect ]
     } cond ;
 

basis/stack-checker/state/state.factor

@@ -1,10 +1,38 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs namespaces sequences kernel definitions math
+USING: assocs arrays namespaces sequences kernel definitions
-effects accessors words fry classes.algebra stack-checker.errors
+math effects accessors words fry classes.algebra
 compiler.units ;
 IN: stack-checker.state
 
+! Recursive state
+SYMBOL: recursive-state
+
+: initial-recursive-state ( word -- state )
+    { } { } 3array 1array ; inline
+
+f initial-recursive-state recursive-state set-global
+
+: add-recursive-state ( word -- rstate )
+    [ recursive-state get ] dip { } { } 3array prefix ;
+
+: add-local-quotation ( recursive-state quot -- rstate )
+    [ unclip first3 swap ] dip prefix swap 3array prefix ;
+
+: add-local-recursive-state ( word label -- rstate )
+    [ recursive-state get ] 2dip
+    [ unclip first3 ] 2dip 2array prefix 3array prefix ;
+
+: recursive-word? ( word -- ? )
+    recursive-state get key? ;
+
+: inline-recursive-label ( word -- label/f )
+    recursive-state get first third at ;
+
+: recursive-quotation? ( quot -- ? )
+    recursive-state get first second [ eq? ] with contains? ;
+
+! Values
 : <value> ( -- value ) \ <value> counter ;
 
 SYMBOL: known-values
@@ -29,9 +57,12 @@ TUPLE: literal < identity-tuple value recursion ;
 : <literal> ( obj -- value )
     recursive-state get \ literal boa ;
 
+GENERIC: (literal) ( value -- literal )
+
+M: literal (literal) ;
+
 : literal ( value -- literal )
-    known dup literal?
+    known (literal) ;
-    [  \ literal-expected inference-warning ] unless ;
 
 ! Result of curry
 TUPLE: curried obj quot ;
@@ -71,20 +102,6 @@ SYMBOL: meta-r
 : init-known-values ( -- )
     H{ } clone known-values set ;
 
-: recursive-label ( word -- label/f )
-    recursive-state get at ;
-
-: local-recursive-state ( -- assoc )
-    recursive-state get dup
-    [ first dup word? [ inline? ] when not ] find drop
-    [ head-slice ] when* ;
-
-: inline-recursive-label ( word -- label/f )
-    local-recursive-state at ;
-
-: recursive-quotation? ( quot -- ? )
-    local-recursive-state [ first eq? ] with contains? ;
-
 ! Words that the current quotation depends on
 SYMBOL: dependencies
 
@@ -98,9 +115,12 @@ SYMBOL: dependencies
 ! Generic words that the current quotation depends on
 SYMBOL: generic-dependencies
 
+: ?class-or ( class/f class -- class' )
+    swap [ class-or ] when* ;
+
 : depends-on-generic ( generic class -- )
     generic-dependencies get dup
-    [ swap '[ null or _ class-or ] change-at ] [ 3drop ] if ;
+    [ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ;
 
 ! Words we've inferred the stack effect of, for rollback
 SYMBOL: recorded

basis/stack-checker/transforms/transforms.factor

@@ -9,7 +9,7 @@ stack-checker.errors ;
 IN: stack-checker.transforms
 
 : give-up-transform ( word -- )
-    dup recursive-label
+    dup recursive-word?
     [ call-recursive-word ]
     [ dup infer-word apply-word/effect ]
     if ;