Clean up inference and fix hygiene issue with macros

core/alien/compiler/compiler.factor

@@ -206,7 +206,7 @@ M: alien-invoke-error summary
     pop-literal nip over set-alien-invoke-library
     pop-literal nip over set-alien-invoke-return
     ! Quotation which coerces parameters to required types
-    dup make-prep-quot infer-quot
+    dup make-prep-quot recursive-state get infer-quot
     ! If symbol doesn't resolve, no stack effect, no compile
     dup alien-invoke-dlsym 2drop
     ! Add node to IR
@@ -243,7 +243,7 @@ M: alien-indirect-error summary
     pop-parameters over set-alien-indirect-parameters
     pop-literal nip over set-alien-indirect-return
     ! Quotation which coerces parameters to required types
-    dup make-prep-quot 1 make-dip infer-quot
+    dup make-prep-quot [ dip ] curry recursive-state get infer-quot
     ! Add node to IR
     dup node,
     ! Magic #: consume the function pointer, too
@@ -282,7 +282,8 @@ M: alien-callback-error summary
     drop "Words calling ``alien-callback'' cannot run in the interpreter. Compile the caller word and try again." ;
 
 : callback-bottom ( node -- )
-    alien-callback-xt [ word-xt <alien> ] curry infer-quot ;
+    alien-callback-xt [ word-xt <alien> ] curry
+    recursive-state get infer-quot ;
 
 \ alien-callback [
     4 ensure-values

core/combinators/combinators-docs.factor

@@ -5,7 +5,6 @@ IN: combinators
 
 ARTICLE: "combinators-quot" "Quotation construction utilities"
 "Some words for creating quotations which can be useful for implementing method combinations and compiler transforms:"
-{ $subsection make-dip }
 { $subsection cond>quot }
 { $subsection case>quot }
 { $subsection alist>quot }
@@ -27,13 +26,6 @@ ARTICLE: "combinators" "Additional combinators"
 
 ABOUT: "combinators"
 
-HELP: make-dip
-{ $values { "quot" "a quotation" } { "n" "a non-negative integer" } { "newquot" "a new quotation" } }
-{ $description "Constructs a quotation which retains the top " { $snippet "n" } " stack items, and applies " { $snippet "quot" } " to what is underneath." }
-{ $examples
-    { $example "USE: quotations" "[ 3 + ] 2 make-dip ." "[ >r >r 3 + r> r> ]" }
-} ;
-
 HELP: alist>quot
 { $values { "default" "a quotation" } { "assoc" "a sequence of quotation pairs" } { "quot" "a new quotation" } }
 { $description "Constructs a quotation which calls the first quotation in each pair of " { $snippet "assoc" } " until one of them outputs a true value, and then calls the second quotation in the corresponding pair. Quotations are called in reverse order, and if no quotation outputs a true value then " { $snippet "default" } " is called." }

core/generator/generator.factor

@@ -73,10 +73,9 @@ SYMBOL: profiler-prologues
 : word-dataflow ( word -- dataflow )
     [
         dup "no-effect" word-prop [ no-effect ] when
-        dup dup add-recursive-state
+        dup specialized-def over dup 2array 1array infer-quot
-        [ specialized-def (dataflow) ] keep
+        finish-word
-        finish-word drop
+    ] with-infer nip ;
-    ] with-infer ;
 
 SYMBOL: compiler-hook
 

core/generic/math/math.factor

@@ -34,7 +34,7 @@ PREDICATE: class math-class ( object -- ? )
 : math-upgrade ( class1 class2 -- quot )
     [ math-class-max ] 2keep
     >r over r> (math-upgrade)
-    >r (math-upgrade) dup empty? [ 1 make-dip ] unless
+    >r (math-upgrade) dup empty? [ [ dip ] curry ] unless
     r> append ;
 
 TUPLE: no-math-method left right generic ;

core/inference/backend/backend.factor

@@ -20,9 +20,6 @@ debugger assocs combinators ;
 : recursive-quotation? ( quot -- ? )
     local-recursive-state [ first eq? ] curry* contains? ;
 
-: add-recursive-state ( word label -- )
-    2array recursive-state [ swap add* ] change ;
-
 TUPLE: inference-error rstate major? ;
 
 : (inference-error) ( ... class important? -- * )
@@ -65,12 +62,11 @@ SYMBOL: terminated?
 
 SYMBOL: recorded
 
-: init-inference ( recursive-state -- )
+: init-inference ( -- )
     terminated? off
     V{ } clone meta-d set
     V{ } clone meta-r set
     0 d-in set
-    recursive-state set
     dataflow-graph off
     current-node off ;
 
@@ -86,25 +82,31 @@ M: wrapper apply-object wrapped apply-literal ;
 : terminate ( -- )
     terminated? on #terminate node, ;
 
-: infer-quot ( quot -- )
+: infer-quot ( quot rstate -- )
-    [ apply-object terminated? get not ] all? drop ;
+    recursive-state get >r
+    recursive-state set
+    [ apply-object terminated? get not ] all? drop
+    r> recursive-state set ;
 
-TUPLE: recursive-quotation-error quot ;
+: infer-quot-recursive ( quot word label -- )
+    2array add* infer-quot ;
+
+: time-bomb ( error -- )
+    [ throw ] curry recursive-state get infer-quot ;
 
 : bad-call ( -- )
-    [ "call must be given a callable" throw ] infer-quot ;
+    "call must be given a callable" time-bomb ;
+
+TUPLE: recursive-quotation-error quot ;
 
 : infer-quot-value ( value -- )
     dup recursive-quotation? [
         value-literal recursive-quotation-error inference-error
     ] [
         dup value-literal callable? [
-            recursive-state get >r
+            dup value-literal
-            [
+            over value-recursion
-                [ value-recursion ] keep f 2array add*
+            rot f infer-quot-recursive
-                recursive-state set
-            ] keep value-literal infer-quot
-            r> recursive-state set
         ] [
             drop bad-call
         ] if
@@ -141,17 +143,6 @@ TUPLE: too-many-r> ;
 : undo-infer ( -- )
     recorded get [ f "inferred-effect" set-word-prop ] each ;
 
-: with-infer ( quot -- )
-    [
-        [
-            { } recursive-state set
-            V{ } clone recorded set
-            f init-inference
-            call
-            check->r
-        ] [ ] [ undo-infer ] cleanup
-    ] with-scope ;
-
 : (consume-values) ( n -- )
     meta-d get [ length swap - ] keep set-length ;
 
@@ -216,6 +207,11 @@ M: object constructor drop f ;
 : reify-all ( -- )
     meta-d get length reify-curries ;
 
+: end-infer ( -- )
+    check->r
+    reify-all
+    f #return node, ;
+
 : unify-lengths ( seq -- newseq )
     dup empty? [
         dup [ length ] map supremum
@@ -349,65 +345,6 @@ TUPLE: no-effect word ;
 
 : no-effect ( word -- * ) \ no-effect inference-warning ;
 
-: nest-node ( -- ) #entry node, ;
-
-: unnest-node ( new-node -- new-node )
-    dup node-param #return node,
-    dataflow-graph get 1array over set-node-children ;
-
-: inline-block ( word -- node-block data )
-    [
-        copy-inference nest-node
-        gensym 2dup add-recursive-state
-        over >r #label r> word-def infer-quot
-        unnest-node
-    ] H{ } make-assoc ;
-
-: apply-infer ( hash -- )
-    { meta-d meta-r d-in terminated? }
-    [ swap [ at ] curry map ] keep
-    [ set ] 2each ;
-
-GENERIC: collect-recursion* ( label node -- )
-
-M: node collect-recursion* 2drop ;
-
-M: #call-label collect-recursion*
-    tuck node-param eq? [ , ] [ drop ] if ;
-
-: collect-recursion ( #label -- seq )
-    dup node-param
-    [ [ swap collect-recursion* ] curry each-node ] { } make ;
-
-: join-values ( node -- )
-    collect-recursion [ node-in-d ] map meta-d get add
-    unify-lengths unify-stacks
-    meta-d [ length tail* ] change ;
-
-: splice-node ( node -- )
-    dup node-successor [
-        dup node, penultimate-node f over set-node-successor
-        dup current-node set
-    ] when drop ;
-
-: inline-closure ( word -- )
-    dup inline-block over recursive-label? [
-        flatten-meta-d >r
-        drop join-values inline-block apply-infer
-        r> over set-node-in-d
-        dup node,
-        collect-recursion [
-            [ flatten-curries ] modify-values
-        ] each
-    ] [
-        apply-infer node-child node-successor splice-node drop
-    ] if ;
-
-: infer-compound ( word -- hash )
-    [
-        recursive-state get init-inference inline-block nip
-    ] with-scope ;
-
 GENERIC: infer-word ( word -- effect )
 
 M: word infer-word no-effect ;
@@ -421,15 +358,22 @@ TUPLE: effect-error word effect ;
     dup pick "declared-effect" word-prop effect<=
     [ 2drop ] [ effect-error ] if ;
 
-: finish-word ( word -- effect )
+: finish-word ( word -- )
     current-effect
     2dup check-effect
     over recorded get push
-    tuck "inferred-effect" set-word-prop ;
+    "inferred-effect" set-word-prop ;
+
+: infer-compound ( word -- )
+    [
+        init-inference
+        dup word-def over dup infer-quot-recursive
+        finish-word
+    ] with-scope ;
 
 M: compound infer-word
-    [ dup infer-compound [ finish-word ] bind ]
+    [ infer-compound ] [ ] [ t "no-effect" set-word-prop ]
-    [ ] [ t "no-effect" set-word-prop ] cleanup ;
+    cleanup ;
 
 : custom-infer ( word -- )
     #! Customized inference behavior
@@ -459,6 +403,60 @@ TUPLE: recursive-declare-error word ;
         \ recursive-declare-error inference-error
     ] if* ;
 
+: nest-node ( -- ) #entry node, ;
+
+: unnest-node ( new-node -- new-node )
+    dup node-param #return node,
+    dataflow-graph get 1array over set-node-children ;
+
+: inline-block ( word -- node-block data )
+    [
+        copy-inference nest-node
+        dup word-def swap gensym
+        recursive-state get pick pick infer-quot-recursive
+         #label unnest-node
+    ] H{ } make-assoc ;
+
+GENERIC: collect-recursion* ( label node -- )
+
+M: node collect-recursion* 2drop ;
+
+M: #call-label collect-recursion*
+    tuck node-param eq? [ , ] [ drop ] if ;
+
+: collect-recursion ( #label -- seq )
+    dup node-param
+    [ [ swap collect-recursion* ] curry each-node ] { } make ;
+
+: join-values ( node -- )
+    collect-recursion [ node-in-d ] map meta-d get add
+    unify-lengths unify-stacks
+    meta-d [ length tail* ] change ;
+
+: splice-node ( node -- )
+    dup node-successor [
+        dup node, penultimate-node f over set-node-successor
+        dup current-node set
+    ] when drop ;
+
+: apply-infer ( hash -- )
+    { meta-d meta-r d-in terminated? }
+    [ swap [ at ] curry map ] keep
+    [ set ] 2each ;
+
+: inline-closure ( word -- )
+    dup inline-block over recursive-label? [
+        flatten-meta-d >r
+        drop join-values inline-block apply-infer
+        r> over set-node-in-d
+        dup node,
+        collect-recursion [
+            [ flatten-curries ] modify-values
+        ] each
+    ] [
+        apply-infer node-child node-successor splice-node drop
+    ] if ;
+
 M: compound apply-object
     [
         dup inline-recursive-label
@@ -469,4 +467,16 @@ M: compound apply-object
     ] if-inline ;
 
 M: undefined apply-object
-    drop [ "Undefined" throw ] infer-quot ;
+    drop "Undefined word" time-bomb ;
+
+: with-infer ( quot -- effect dataflow )
+    [
+        [
+            V{ } clone recorded set
+            init-inference
+            call
+            end-infer
+            current-effect
+            dataflow-graph get
+        ] [ ] [ undo-infer ] cleanup
+    ] with-scope ;

core/inference/inference.factor

@@ -9,19 +9,20 @@ namespaces quotations ;
 GENERIC: infer ( quot -- effect )
 
 M: callable infer ( quot -- effect )
-    [ infer-quot current-effect ] with-infer ;
+    [ f infer-quot ] with-infer drop ;
 
 : infer. ( quot -- )
     infer effect>string print ;
 
-: (dataflow) ( quot -- dataflow )
+GENERIC: dataflow ( quot -- dataflow )
-    infer-quot
-    reify-all
-    f #return node,
-    dataflow-graph get ;
 
-: dataflow ( quot -- dataflow )
+M: callable dataflow
-    [ (dataflow) ] with-infer ;
+    [ f infer-quot ] with-infer nip ;
 
-: dataflow-with ( quot stack -- dataflow )
+GENERIC# dataflow-with 1 ( quot stack -- dataflow )
-    [ V{ } like meta-d set (dataflow) ] with-infer ;
+
+M: callable dataflow-with
+    [
+        V{ } like meta-d set
+        f infer-quot
+    ] with-infer nip ;

core/inference/known-words/known-words.factor

@@ -69,6 +69,7 @@ M: object infer-call
     ] [
         drop
         [ "execute must be given a word" throw ]
+        recursive-state get
         infer-quot
     ] if
 ] "infer" set-word-prop
@@ -76,7 +77,8 @@ M: object infer-call
 \ if [
     3 ensure-values
     2 d-tail [ special? ] contains? [
-        [ rot [ drop call ] [ nip call ] if ] infer-quot
+        [ rot [ drop call ] [ nip call ] if ]
+        recursive-state get infer-quot
     ] [
         [ #values ]
         2 #drop node, pop-d pop-d swap 2array

core/inference/transforms/transforms.factor

@@ -5,16 +5,16 @@ quotations assocs combinators math.bitfields inference.backend
 inference.dataflow tuples.private ;
 IN: inference.transforms
 
-: pop-literals ( n -- seq )
+: pop-literals ( n -- rstate seq )
-    [ ensure-values ] keep
+    dup zero? [ drop f ] [
-    [ d-tail ] keep
+        [ ensure-values ] keep [ d-tail ] keep (consume-values)
-    (consume-values)
+        dup value-recursion swap [ value-literal ] map
-    [ value-literal ] map ;
+    ] if ;
 
 : transform-quot ( quot n -- newquot )
-    [
+    [ pop-literals [ ] each ] curry
-        , \ pop-literals , [ [ ] each ] % % \ infer-quot ,
+    swap
-    ] [ ] make ;
+    [ swap infer-quot ] 3compose ;
 
 : define-transform ( word quot n -- )
     transform-quot "infer" set-word-prop ;

core/quotations/quotations.factor

@@ -26,10 +26,6 @@ M: quotation like drop dup quotation? [ >quotation ] unless ;
 
 INSTANCE: quotation immutable-sequence
 
-: make-dip ( quot n -- newquot )
-    dup \ >r <repetition> -rot \ r> <repetition> 3append
-    >quotation ;
-
 : 1quotation ( obj -- quot ) 1array >quotation ;
 
 GENERIC: literalize ( obj -- wrapped )

extra/cocoa/messages/messages.factor

@@ -3,7 +3,8 @@
 USING: alien alien.c-types alien.compiler
 arrays assocs combinators compiler inference.transforms kernel
 math namespaces parser prettyprint prettyprint.sections
-quotations sequences strings words cocoa.runtime io macros ;
+quotations sequences strings words cocoa.runtime io macros
+combinators.lib ;
 IN: cocoa.messages
 
 : make-sender ( method function -- quot )
@@ -74,7 +75,7 @@ H{ } clone objc-methods set-global
         [ \ <super> , ] when
         swap cache-selector , \ selector ,
     ] [ ] make
-    swap second length 2 - make-dip ;
+    swap second length 2 - [ ndip ] curry ;
 
 MACRO: (send) ( selector super? -- quot )
     [