new dataflow IR

TODO.FACTOR.txt

@@ -6,8 +6,9 @@
 <magnus--> http://www.caddr.com/macho/archives/sbcl-devel/2005-3/4764.html
 <magnus--> http://clozure.com/cgi-bin/viewcvs.cgi/ccl/lisp-kernel/lisp-exceptions.c?rev=1.9&content-type=text/vnd.viewcvs-markup
 
+- single-stepper and variable access: wrong namespace?
+- [ over ] generics no-method
 - investigate if COPYING_GEN needs a fix
-- alien-global type wrong
 - simplifier:
   - dead loads not optimized out
   - kill tag-fixnum/untag-fixnum

library/alien/compiler.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: alien
-USING: assembler compiler compiler-backend errors generic
+USING: assembler compiler compiler-frontend compiler-backend
-inference kernel lists math namespaces sequences stdio strings
+errors generic inference kernel lists math namespaces sequences
-unparser words ;
+stdio strings unparser words ;
 
 ! ! ! WARNING ! ! !
 ! Reloading this file into a running Factor instance on Win32
@@ -42,48 +42,42 @@ M: alien-error error. ( error -- )
         " symbol." %
     ] make-string print ;
 
-: alien-invoke ( ... returns library function parameters -- ... )
+: alien-invoke ( ... return library function parameters -- ... )
     #! Call a C library function.
-    #! 'returns' is a type spec, and 'parameters' is a list of
+    #! 'return' is a type spec, and 'parameters' is a list of
     #! type specs. 'library' is an entry in the "libraries"
     #! namespace.
     drop <alien-error> throw ;
 
-! These are set in the alien-invoke dataflow IR node.
+TUPLE: alien-node return parameters ;
-SYMBOL: alien-returns
+C: alien-node make-node ;
-SYMBOL: alien-parameters
 
-: set-alien-returns ( returns node -- )
+: set-alien-return ( return node -- )
-    [ dup alien-returns set ] bind
+    2dup set-alien-node-return
-    "void" = [
+    swap "void" = [
-        [ object ] produce-d 1 0 node-outputs
+        drop
-    ] unless ;
+    ] [
+        [ object ] produce-d 1 0 rot node-outputs
+    ] ifte ;
 
 : set-alien-parameters ( parameters node -- )
-    [ dup alien-parameters set ] bind
+    2dup set-alien-node-parameters
-    [ drop object ] map dup dup ensure-d
+    >r [ drop object ] map dup dup ensure-d
-    length 0 node-inputs consume-d ;
+    length 0 r> node-inputs consume-d ;
 
 : ensure-dlsym ( symbol library -- ) load-library dlsym drop ;
 
-: alien-invoke-node ( returns params function library -- )
+: alien-node ( return params function library -- )
     #! We should fail if the library does not exist, so that
     #! compilation does not keep trying to compile FFI words
     #! over and over again if the library is not loaded.
     2dup ensure-dlsym
-    cons \ alien-invoke dataflow,
+    cons param-node <alien-node>
     [ set-alien-parameters ] keep
-    set-alien-returns ;
+    [ set-alien-return ] keep
+    node, ;
 
-: infer-alien-invoke ( -- )
+: parameters alien-node-parameters reverse ;
-    \ alien-invoke "infer-effect" word-prop car ensure-d
-    pop-literal nip
-    pop-literal nip >r
-    pop-literal nip
-    pop-literal nip -rot
-    r> swap alien-invoke-node ;
-
-: parameters [ alien-parameters get reverse ] bind ;
 
 : stack-space ( parameters -- n )
     0 swap [ c-size cell align + ] each ;
@@ -101,57 +95,35 @@ SYMBOL: alien-parameters
     parameters
     dup stack-space
     dup %parameters , >r
-    dup dup length swap [ >r 1 - dup r> unbox-parameter ] each drop
+    dup dup length swap [
+        >r 1 - dup r> unbox-parameter
+    ] each drop
     length [ %parameter ] project % r> ;
 
-: linearize-returns ( returns -- )
+: linearize-return ( return -- )
-    [ alien-returns get ] bind dup "void" = [
+    alien-node-return dup "void" = [
         drop
     ] [
         c-type [ "boxer" get "box-op" get ] bind execute ,
     ] ifte ;
 
-: linearize-alien-invoke ( node -- )
+M: alien-node linearize-node* ( node -- )
     dup linearize-parameters >r
-    dup [ node-param get ] bind %alien-invoke ,
+    dup node-param %alien-invoke ,
-    dup [ node-param get cdr library-abi "stdcall" = ] bind
+    dup node-param cdr library-abi "stdcall" =
     r> swap [ drop ] [ %cleanup , ] ifte
-    linearize-returns ;
+    linearize-return ;
 
-\ alien-invoke [ linearize-alien-invoke ] "linearizer" set-word-prop
+\ alien-invoke [ [ string object string general-list ] [ ] ]
-
-\ alien-invoke [ [ string string string general-list ] [ ] ]
 "infer-effect" set-word-prop
 
-\ alien-invoke [ infer-alien-invoke ] "infer" set-word-prop
+\ alien-invoke [
-
-: alien-global ( type library name -- value )
-    #! Fetch the value of C global variable.
-    #! 'type' is a type spec. 'library' is an entry in the
-    #! "libraries" namespace.
-    <alien-error> throw ;
-
-: alien-global-node ( type name library -- )
-    2dup ensure-dlsym
-    cons \ alien-global dataflow,
-    set-alien-returns ;
-
-: infer-alien-global ( -- )
-    \ alien-global "infer-effect" word-prop car ensure-d
     pop-literal nip
+    pop-literal nip >r
     pop-literal nip
     pop-literal nip -rot
-    alien-global-node ;
+    r> swap alien-node
-
+] "infer" set-word-prop
-: linearize-alien-global ( node -- )
-    dup [ node-param get ] bind %alien-global ,
-    linearize-returns ;
-
-\ alien-global [ linearize-alien-global ] "linearizer" set-word-prop
-
-\ alien-global [ [ string string string ] [ object ] ] "infer-effect" set-word-prop
-
-\ alien-global [ infer-alien-global ] "infer" set-word-prop
 
 global [
     "libraries" get [ <namespace> "libraries" set ] unless

library/combinators.factor

@@ -5,6 +5,9 @@ IN: kernel
 : slip ( quot x -- x | quot: -- )
     >r call r> ; inline
 
+: 2slip ( quot x y -- x y | quot: -- )
+    >r >r call r> r> ; inline
+
 : keep ( x quot -- x | quot: x -- )
     over >r call r> ; inline
 

library/compiler/intrinsics.factor

@@ -5,55 +5,33 @@ USING: assembler compiler-backend generic hashtables inference
 kernel kernel-internals lists math math-internals namespaces
 sequences words ;
 
-: immediate? ( obj -- ? )
-    #! fixnums and f have a pointerless representation, and
-    #! are compiled immediately. Everything else can be moved
-    #! by GC, and is indexed through a table.
-    dup fixnum? swap f eq? or ;
-
-: push-1 ( obj -- )
-    0 swap literal-value dup
-    immediate? [ %immediate ] [ %indirect ] ifte , ;
-
-#push [
-    [ node-produce-d get ] bind
-    dup length dup %inc-d ,
-    1 - swap [
-        push-1 0 over %replace-d ,
-    ] each drop
-] "linearizer" set-word-prop
-
-#drop [
-    [ node-consume-d get length ] bind %dec-d ,
-] "linearizer" set-word-prop
-
 \ dup [
     drop
     in-1
     1 %inc-d ,
     out-1
-] "linearizer" set-word-prop
+] "intrinsic" set-word-prop
 
 \ swap [
     drop
     in-2
     0 0 %replace-d ,
     1 1 %replace-d ,
-] "linearizer" set-word-prop
+] "intrinsic" set-word-prop
 
 \ over [
     drop
     0 1 %peek-d ,
     1 %inc-d ,
     out-1
-] "linearizer" set-word-prop
+] "intrinsic" set-word-prop
 
 \ pick [
     drop
     0 2 %peek-d ,
     1 %inc-d ,
     out-1
-] "linearizer" set-word-prop
+] "intrinsic" set-word-prop
 
 \ >r [
     drop
@@ -61,7 +39,7 @@ sequences words ;
     1 %inc-r ,
     1 %dec-d ,
     0 0 %replace-r ,
-] "linearizer" set-word-prop
+] "intrinsic" set-word-prop
 
 \ r> [
     drop
@@ -69,20 +47,18 @@ sequences words ;
     1 %inc-d ,
     1 %dec-r ,
     out-1
-] "linearizer" set-word-prop
+] "intrinsic" set-word-prop
 
-: node-peek ( node -- obj ) node-consume-d swap hash peek ;
+: node-peek ( node -- obj ) node-in-d peek ;
 
 : peek-2 dup length 2 - swap nth ;
-: node-peek-2 ( node -- obj ) node-consume-d swap hash peek-2 ;
+: node-peek-2 ( node -- obj ) node-in-d peek-2 ;
 
 : typed? ( value -- ? ) value-types length 1 = ;
 
-\ slot t "intrinsic" set-word-prop
-
 : slot@ ( node -- n )
     #! Compute slot offset.
-    node-consume-d swap hash
+    node-in-d
     dup peek literal-value cell *
     swap peek-2 value-types car type-tag - ;
 
@@ -103,9 +79,7 @@ sequences words ;
         0 %untag ,
         1 0 %slot ,
     ] ifte  out-1
-] "linearizer" set-word-prop
+] "intrinsic" set-word-prop
-
-\ set-slot t "intrinsic" set-word-prop
 
 \ set-slot [
     dup typed-literal? [
@@ -120,9 +94,7 @@ sequences words ;
         1 %untag ,
         0 1 2 %set-slot ,
     ] ifte
-] "linearizer" set-word-prop
+] "intrinsic" set-word-prop
-
-\ type t "intrinsic" set-word-prop
 
 \ type [
     drop
@@ -130,9 +102,7 @@ sequences words ;
     0 %type ,
     0 %tag-fixnum ,
     out-1
-] "linearizer" set-word-prop
+] "intrinsic" set-word-prop
-
-\ arithmetic-type t "intrinsic" set-word-prop
 
 \ arithmetic-type [
     drop
@@ -141,25 +111,21 @@ sequences words ;
     0 %tag-fixnum ,
     1 %inc-d ,
     out-1
-] "linearizer" set-word-prop
+] "intrinsic" set-word-prop
-
-\ getenv t "intrinsic" set-word-prop
 
 \ getenv [
     1 %dec-d ,
     node-peek literal-value 0 <vreg> swap %getenv ,
     1 %inc-d ,
     out-1
-] "linearizer" set-word-prop
+] "intrinsic" set-word-prop
-
-\ setenv t "intrinsic" set-word-prop
 
 \ setenv [
     1 %dec-d ,
     in-1
     node-peek literal-value 0 <vreg> swap %setenv ,
     1 %dec-d ,
-] "linearizer" set-word-prop
+] "intrinsic" set-word-prop
 
 : binary-op-reg ( op out -- )
     >r in-2
@@ -194,13 +160,10 @@ sequences words ;
     [[ fixnum>       %fixnum>       ]]
     [[ eq?           %eq?           ]]
 ] [
-    uncons over t "intrinsic" set-word-prop
+    uncons [ literal, 0 , \ binary-op , ] make-list
-    [ literal, 0 , \ binary-op , ] make-list
+    "intrinsic" set-word-prop
-    "linearizer" set-word-prop
 ] each
 
-\ fixnum* t "intrinsic" set-word-prop
-
 : slow-fixnum* \ %fixnum* 0 binary-op-reg ;
 
 \ fixnum* [
@@ -217,24 +180,20 @@ sequences words ;
     ] [
         drop slow-fixnum*
     ] ifte
-] "linearizer" set-word-prop
+] "intrinsic" set-word-prop
-
-\ fixnum-mod t "intrinsic" set-word-prop
 
 \ fixnum-mod [
     ! This is not clever. Because of x86, %fixnum-mod is
     ! hard-coded to put its output in vreg 2, which happends to
     ! be EDX there.
     drop \ %fixnum-mod 2 binary-op-reg
-] "linearizer" set-word-prop
+] "intrinsic" set-word-prop
 
 \ fixnum/i t "intrinsic" set-word-prop
 
 \ fixnum/i [
     drop \ %fixnum/i 0 binary-op-reg
-] "linearizer" set-word-prop
+] "intrinsic" set-word-prop
-
-\ fixnum/mod t "intrinsic" set-word-prop
 
 \ fixnum/mod [
     ! See the remark on fixnum-mod for vreg usage
@@ -243,16 +202,14 @@ sequences words ;
     0 <vreg> 1 <vreg> %fixnum/mod ,
     2 0 %replace-d ,
     0 1 %replace-d ,
-] "linearizer" set-word-prop
+] "intrinsic" set-word-prop
-
-\ fixnum-bitnot t "intrinsic" set-word-prop
 
 \ fixnum-bitnot [
     drop
     in-1
     0 %fixnum-bitnot ,
     out-1
-] "linearizer" set-word-prop
+] "intrinsic" set-word-prop
 
 : slow-shift ( -- ) \ fixnum-shift %call , ;
 
@@ -289,12 +246,10 @@ sequences words ;
         ] ifte
     ] ifte ;
 
-\ fixnum-shift t "intrinsic" set-word-prop
-
 \ fixnum-shift [
     node-peek dup literal? [
         literal-value fast-shift
     ] [
         drop slow-shift
     ] ifte
-] "linearizer" set-word-prop
+] "intrinsic" set-word-prop

library/compiler/linearizer.factor

@@ -4,66 +4,69 @@ IN: compiler-frontend
 USING: compiler-backend inference kernel kernel-internals lists
 math namespaces words strings errors prettyprint sequences ;
 
-: >linear ( node -- )
+GENERIC: linearize-node* ( node -- )
-    #! Dataflow OPs have a linearizer word property. This
+M: f linearize-node* ( f -- ) drop ;
-    #! quotation is executed to convert the node into linear
-    #! form.
-    "linearizer" [ "No linearizer" throw ] apply-dataflow ;
 
-: (linearize) ( dataflow -- )
+: linearize-node ( node -- )
-    [ >linear ] each ;
+    [
+        dup linearize-node* node-successor linearize-node
+    ] when* ;
 
 : linearize ( dataflow -- linear )
     #! Transform dataflow IR into linear IR. This strips out
-    #! stack flow information, flattens conditionals into
+    #! stack flow information, and flattens conditionals into
-    #! jumps and labels, and turns dataflow IR nodes into
+    #! jumps and labels.
-    #! lists where the first element is an operation, and the
+    [ %prologue , linearize-node ] make-list ;
-    #! rest is arguments.
-    [ %prologue , (linearize) ] make-list ;
 
-: linearize-label ( node -- )
+M: #label linearize-node* ( node -- )
-    #! Labels are tricky, because they might contain non-tail
-    #! calls. So we push the address of the location right after
-    #! the #label , then linearize the #label , then add a #return
-    #! node to the linear IR. The simplifier will take care of
-    #! this in the common case where the labelled block does
-    #! not contain non-tail recursive calls to itself.
     <label> dup %return-to , >r
-    dup [ node-label get ] bind %label ,
+    dup node-param %label ,
-    [ node-param get ] bind (linearize)
+    node-children car linearize-node
     f %return ,
     r> %label , ;
 
-#label [
+M: #call linearize-node* ( node -- )
-    linearize-label
+    dup node-param
-] "linearizer" set-word-prop
+    dup "intrinsic" word-prop [
+        call
+    ] [
+        %call , drop
+    ] ?ifte ;
 
-#call [
+M: #call-label linearize-node* ( node -- )
-    [ node-param get ] bind %call ,
+    node-param %call-label , ;
-] "linearizer" set-word-prop
 
-#call-label [
+: immediate? ( obj -- ? )
-    [ node-param get ] bind %call-label ,
+    #! fixnums and f have a pointerless representation, and
-] "linearizer" set-word-prop
+    #! are compiled immediately. Everything else can be moved
+    #! by GC, and is indexed through a table.
+    dup fixnum? swap f eq? or ;
+
+: push-1 ( obj -- )
+    0 swap literal-value dup
+    immediate? [ %immediate ] [ %indirect ] ifte , ;
+
+M: #push linearize-node* ( node -- )
+    node-out-d dup length dup %inc-d ,
+    1 - swap [ push-1 0 over %replace-d , ] each drop ;
+
+M: #drop linearize-node* ( node -- )
+    node-in-d length %dec-d , ;
 
 : ifte-head ( label -- )
     in-1  1 %dec-d , 0 %jump-t , ;
 
-: linearize-ifte ( param -- )
+M: #ifte linearize-node* ( node -- )
     #! The parameter is a list of two lists, each one a dataflow
     #! IR.
-    2unlist  <label> [
+    node-children 2unlist  <label> [
         ifte-head
-        (linearize) ( false branch )
+        linearize-node ( false branch )
         <label> dup %jump-label ,
     ] keep %label , ( branch target of BRANCH-T )
-    swap (linearize) ( true branch )
+    swap linearize-node ( true branch )
     %label , ( branch target of false branch end ) ;
 
-\ ifte [
-    [ node-param get ] bind linearize-ifte
-] "linearizer" set-word-prop
-
 : dispatch-head ( vtable -- end label/code )
     #! Output the jump table insn and return a list of
     #! label/branch pairs.
@@ -77,17 +80,15 @@ math namespaces words strings errors prettyprint sequences ;
 
 : dispatch-body ( end label/param -- )
     #! Output each branch, with a jump to the end label.
-    [ uncons %label , (linearize) %jump-label , ] each-with ;
+    [ uncons %label , linearize-node %jump-label , ] each-with ;
 
-: linearize-dispatch ( vtable -- )
+M: #dispatch linearize-node* ( vtable -- )
     #! The parameter is a list of lists, each one is a branch to
     #! take in case the top of stack has that type.
-    dispatch-head dupd dispatch-body %label , ;
+    node-children dispatch-head dupd dispatch-body %label , ;
 
-\ dispatch [
+M: #values linearize-node* ( node -- )
-    [ node-param get ] bind linearize-dispatch
+    drop ;
-] "linearizer" set-word-prop
 
-#values [ drop ] "linearizer" set-word-prop
+M: #return linearize-node* ( node -- )
-
+    drop  f %return , ;
-#return [ drop f %return , ] "linearizer" set-word-prop

library/compiler/optimizer.factor

@@ -11,207 +11,209 @@ sequences vectors words words ;
 ! lifted to their call sites. Also, #label nodes are inlined if
 ! their children do not make a recursive call to the label.
 
-: scan-literal ( node -- )
+! : scan-literal ( node -- )
-    #! If the node represents a literal push, add the literal to
+!     #! If the node represents a literal push, add the literal to
-    #! the list being constructed.
+!     #! the list being constructed.
-    "scan-literal" [ drop ] apply-dataflow ;
+!     "scan-literal" [ drop ] apply-dataflow ;
+! 
+! : (scan-literals) ( dataflow -- )
+!     [ scan-literal ] each ;
+! 
+! : scan-literals ( dataflow -- list )
+!     [ (scan-literals) ] make-list ;
+! 
+! : scan-branches ( branches -- )
+!     #! Collect all literals from all branches.
+!     [ node-param get ] bind [ [ scan-literal ] each ] each ;
+! 
+! : mentions-literal? ( literal list -- ? )
+!     #! Does the given list of result objects refer to this
+!     #! literal?
+!     [ value= ] some-with? ;
+! 
+! : consumes-literal? ( literal node -- ? )
+!     #! Does the dataflow node consume the literal?
+!     [
+!         dup node-consume-d get mentions-literal? swap
+!         dup node-consume-r get mentions-literal? nip or
+!     ] bind ;
+! 
+! : produces-literal? ( literal node -- ? )
+!     #! Does the dataflow node produce the literal?
+!     [
+!         dup node-produce-d get mentions-literal? swap
+!         dup node-produce-r get mentions-literal? nip or
+!     ] bind ;
+! 
+! : (can-kill?) ( literal node -- ? )
+!     #! Return false if the literal appears as input to this
+!     #! node, and this node is not a stack operation.
+!     2dup consumes-literal? >r produces-literal? r> or not ;
+! 
+! : can-kill? ( literal dataflow -- ? )
+!     #! Return false if the literal appears in any node in the
+!     #! list.
+!     [ dupd "can-kill" [ (can-kill?) ] apply-dataflow ] all? nip ;
+! 
+! : kill-set ( dataflow -- list )
+!     #! Push a list of literals that may be killed in the IR.
+!     dup scan-literals [ over can-kill? ] subset nip ;
+! 
+! SYMBOL: branch-returns
+! 
+! : can-kill-branches? ( literal node -- ? )
+!     #! Check if the literal appears in either branch. This
+!     #! assumes that the last element of each branch is a #values
+!     #! node.
+!     2dup consumes-literal? [
+!         2drop f
+!     ] [
+!         [ node-param get ] bind
+!         [
+!             dup [
+!                 peek [ node-consume-d get >vector ] bind
+!             ] map
+!             unify-stacks >list
+!             branch-returns set
+!             [ dupd can-kill? ] all? nip
+!         ] with-scope
+!     ] ifte ;
+! 
+! : kill-node ( literals node -- )
+!     swap [ over (can-kill?) ] all? [ , ] [ drop ] ifte ;
+! 
+! : (kill-nodes) ( literals dataflow -- )
+!     #! Append live nodes to currently constructing list.
+!     [ "kill-node" [ nip , ] apply-dataflow ] each-with ;
+! 
+! : kill-nodes ( literals dataflow -- dataflow )
+!     #! Remove literals and construct a list.
+!     [ (kill-nodes) ] make-list ;
+! 
+! : optimize ( dataflow -- dataflow )
+!     #! Remove redundant literals from the IR. The original IR
+!     #! is destructively modified.
+!     dup kill-set swap kill-nodes ;
+! 
+! : kill-branches ( literals node -- )
+!     [
+!         node-param [ [ dupd kill-nodes ] map nip ] change
+!     ] extend , ;
+! 
+! : kill-literal ( literals values -- values )
+!     [
+!         swap [ swap value= ] some-with? not
+!     ] subset-with ;
+! 
+! #push [
+!     [ node-produce-d get ] bind [ literal-value ] map %
+! ] "scan-literal" set-word-prop
+! 
+! #push [ 2drop t ] "can-kill" set-word-prop
+! 
+! #push [
+!     [ node-produce-d [ kill-literal ] change ] extend ,
+! ] "kill-node" set-word-prop
+! 
+! #drop [ 2drop t ] "can-kill" set-word-prop
+! 
+! #drop [
+!     [ node-consume-d [ kill-literal ] change ] extend ,
+! ] "kill-node" set-word-prop
+! 
+! #label [
+!     [ node-param get ] bind (scan-literals)
+! ] "scan-literal" set-word-prop
+! 
+! #label [
+!     [ node-param get ] bind can-kill?
+! ] "can-kill" set-word-prop
+! 
+! #call-label [
+!     [ node-param get ] bind =
+! ] "calls-label" set-word-prop
+! 
+! : calls-label? ( label list -- ? )
+!     [ "calls-label" [ 2drop f ] apply-dataflow ] some-with? ;
+! 
+! #label [
+!     [ node-param get ] bind calls-label?
+! ] "calls-label" set-word-prop
+! 
+! : branches-call-label? ( label list -- ? )
+!     [ calls-label? ] some-with? ;
+! 
+! \ ifte [
+!     [ node-param get ] bind branches-call-label?
+! ] "calls-label" set-word-prop
+! 
+! \ dispatch [
+!     [ node-param get ] bind branches-call-label?
+! ] "calls-label" set-word-prop
+! 
+! #label [ ( literals node -- )
+!     [ node-param [ kill-nodes ] change ] extend ,
+! ] "kill-node" set-word-prop
+! 
+! #values [
+!     dupd consumes-literal? [
+!         branch-returns get mentions-literal?
+!     ] [
+!         drop t
+!     ] ifte
+! ] "can-kill" set-word-prop
+! 
+! \ ifte [ scan-branches ] "scan-literal" set-word-prop
+! \ ifte [ can-kill-branches? ] "can-kill" set-word-prop
+! \ ifte [ kill-branches ] "kill-node" set-word-prop
+! 
+! \ dispatch [ scan-branches ] "scan-literal" set-word-prop
+! \ dispatch [ can-kill-branches? ] "can-kill" set-word-prop
+! \ dispatch [ kill-branches ] "kill-node" set-word-prop
+! 
+! ! Don't care about inputs to recursive combinator calls
+! #call-label [ 2drop t ] "can-kill" set-word-prop
+! 
+! \ drop [ 2drop t ] "can-kill" set-word-prop
+! \ drop [ kill-node ] "kill-node" set-word-prop
+! \ dup [ 2drop t ] "can-kill" set-word-prop
+! \ dup [ kill-node ] "kill-node" set-word-prop
+! \ swap [ 2drop t ] "can-kill" set-word-prop
+! \ swap [ kill-node ] "kill-node" set-word-prop
+! 
+! : kill-mask ( killing inputs -- mask )
+!     [ over [ over value= ] some? >boolean nip ] map nip ;
+! 
+! : reduce-stack-op ( literals node map -- )
+!     #! If certain values passing through a stack op are being
+!     #! killed, the stack op can be reduced, in extreme cases
+!     #! to a no-op.
+!     -rot [
+!         [ node-consume-d get ] bind kill-mask swap assoc
+!     ] keep
+!     over [ [ node-op set ] extend , ] [ 2drop ] ifte ;
+! 
+! \ over [ 2drop t ] "can-kill" set-word-prop
+! \ over [
+!     [
+!         [[ [ f f ] over ]]
+!         [[ [ f t ] dup  ]]
+!     ] reduce-stack-op
+! ] "kill-node" set-word-prop
+! 
+! \ pick [ 2drop t ] "can-kill" set-word-prop
+! \ pick [
+!     [
+!         [[ [ f f f ] pick ]]
+!         [[ [ f f t ] over ]]
+!         [[ [ f t f ] over ]]
+!         [[ [ f t t ] dup  ]]
+!     ] reduce-stack-op
+! ] "kill-node" set-word-prop
+! 
+! \ >r [ 2drop t ] "can-kill" set-word-prop
+! \ >r [ kill-node ] "kill-node" set-word-prop
+! \ r> [ 2drop t ] "can-kill" set-word-prop
+! \ r> [ kill-node ] "kill-node" set-word-prop
 
-: (scan-literals) ( dataflow -- )
+: optimize ;
-    [ scan-literal ] each ;
-
-: scan-literals ( dataflow -- list )
-    [ (scan-literals) ] make-list ;
-
-: scan-branches ( branches -- )
-    #! Collect all literals from all branches.
-    [ node-param get ] bind [ [ scan-literal ] each ] each ;
-
-: mentions-literal? ( literal list -- ? )
-    #! Does the given list of result objects refer to this
-    #! literal?
-    [ value= ] some-with? ;
-
-: consumes-literal? ( literal node -- ? )
-    #! Does the dataflow node consume the literal?
-    [
-        dup node-consume-d get mentions-literal? swap
-        dup node-consume-r get mentions-literal? nip or
-    ] bind ;
-
-: produces-literal? ( literal node -- ? )
-    #! Does the dataflow node produce the literal?
-    [
-        dup node-produce-d get mentions-literal? swap
-        dup node-produce-r get mentions-literal? nip or
-    ] bind ;
-
-: (can-kill?) ( literal node -- ? )
-    #! Return false if the literal appears as input to this
-    #! node, and this node is not a stack operation.
-    2dup consumes-literal? >r produces-literal? r> or not ;
-
-: can-kill? ( literal dataflow -- ? )
-    #! Return false if the literal appears in any node in the
-    #! list.
-    [ dupd "can-kill" [ (can-kill?) ] apply-dataflow ] all? nip ;
-
-: kill-set ( dataflow -- list )
-    #! Push a list of literals that may be killed in the IR.
-    dup scan-literals [ over can-kill? ] subset nip ;
-
-SYMBOL: branch-returns
-
-: can-kill-branches? ( literal node -- ? )
-    #! Check if the literal appears in either branch. This
-    #! assumes that the last element of each branch is a #values
-    #! node.
-    2dup consumes-literal? [
-        2drop f
-    ] [
-        [ node-param get ] bind
-        [
-            dup [
-                peek [ node-consume-d get >vector ] bind
-            ] map
-            unify-stacks >list
-            branch-returns set
-            [ dupd can-kill? ] all? nip
-        ] with-scope
-    ] ifte ;
-
-: kill-node ( literals node -- )
-    swap [ over (can-kill?) ] all? [ , ] [ drop ] ifte ;
-
-: (kill-nodes) ( literals dataflow -- )
-    #! Append live nodes to currently constructing list.
-    [ "kill-node" [ nip , ] apply-dataflow ] each-with ;
-
-: kill-nodes ( literals dataflow -- dataflow )
-    #! Remove literals and construct a list.
-    [ (kill-nodes) ] make-list ;
-
-: optimize ( dataflow -- dataflow )
-    #! Remove redundant literals from the IR. The original IR
-    #! is destructively modified.
-    dup kill-set swap kill-nodes ;
-
-: kill-branches ( literals node -- )
-    [
-        node-param [ [ dupd kill-nodes ] map nip ] change
-    ] extend , ;
-
-: kill-literal ( literals values -- values )
-    [
-        swap [ swap value= ] some-with? not
-    ] subset-with ;
-
-#push [
-    [ node-produce-d get ] bind [ literal-value ] map %
-] "scan-literal" set-word-prop
-
-#push [ 2drop t ] "can-kill" set-word-prop
-
-#push [
-    [ node-produce-d [ kill-literal ] change ] extend ,
-] "kill-node" set-word-prop
-
-#drop [ 2drop t ] "can-kill" set-word-prop
-
-#drop [
-    [ node-consume-d [ kill-literal ] change ] extend ,
-] "kill-node" set-word-prop
-
-#label [
-    [ node-param get ] bind (scan-literals)
-] "scan-literal" set-word-prop
-
-#label [
-    [ node-param get ] bind can-kill?
-] "can-kill" set-word-prop
-
-#call-label [
-    [ node-param get ] bind =
-] "calls-label" set-word-prop
-
-: calls-label? ( label list -- ? )
-    [ "calls-label" [ 2drop f ] apply-dataflow ] some-with? ;
-
-#label [
-    [ node-param get ] bind calls-label?
-] "calls-label" set-word-prop
-
-: branches-call-label? ( label list -- ? )
-    [ calls-label? ] some-with? ;
-
-\ ifte [
-    [ node-param get ] bind branches-call-label?
-] "calls-label" set-word-prop
-
-\ dispatch [
-    [ node-param get ] bind branches-call-label?
-] "calls-label" set-word-prop
-
-#label [ ( literals node -- )
-    [ node-param [ kill-nodes ] change ] extend ,
-] "kill-node" set-word-prop
-
-#values [
-    dupd consumes-literal? [
-        branch-returns get mentions-literal?
-    ] [
-        drop t
-    ] ifte
-] "can-kill" set-word-prop
-
-\ ifte [ scan-branches ] "scan-literal" set-word-prop
-\ ifte [ can-kill-branches? ] "can-kill" set-word-prop
-\ ifte [ kill-branches ] "kill-node" set-word-prop
-
-\ dispatch [ scan-branches ] "scan-literal" set-word-prop
-\ dispatch [ can-kill-branches? ] "can-kill" set-word-prop
-\ dispatch [ kill-branches ] "kill-node" set-word-prop
-
-! Don't care about inputs to recursive combinator calls
-#call-label [ 2drop t ] "can-kill" set-word-prop
-
-\ drop [ 2drop t ] "can-kill" set-word-prop
-\ drop [ kill-node ] "kill-node" set-word-prop
-\ dup [ 2drop t ] "can-kill" set-word-prop
-\ dup [ kill-node ] "kill-node" set-word-prop
-\ swap [ 2drop t ] "can-kill" set-word-prop
-\ swap [ kill-node ] "kill-node" set-word-prop
-
-: kill-mask ( killing inputs -- mask )
-    [ over [ over value= ] some? >boolean nip ] map nip ;
-
-: reduce-stack-op ( literals node map -- )
-    #! If certain values passing through a stack op are being
-    #! killed, the stack op can be reduced, in extreme cases
-    #! to a no-op.
-    -rot [
-        [ node-consume-d get ] bind kill-mask swap assoc
-    ] keep
-    over [ [ node-op set ] extend , ] [ 2drop ] ifte ;
-
-\ over [ 2drop t ] "can-kill" set-word-prop
-\ over [
-    [
-        [[ [ f f ] over ]]
-        [[ [ f t ] dup  ]]
-    ] reduce-stack-op
-] "kill-node" set-word-prop
-
-\ pick [ 2drop t ] "can-kill" set-word-prop
-\ pick [
-    [
-        [[ [ f f f ] pick ]]
-        [[ [ f f t ] over ]]
-        [[ [ f t f ] over ]]
-        [[ [ f t t ] dup  ]]
-    ] reduce-stack-op
-] "kill-node" set-word-prop
-
-\ >r [ 2drop t ] "can-kill" set-word-prop
-\ >r [ kill-node ] "kill-node" set-word-prop
-\ r> [ 2drop t ] "can-kill" set-word-prop
-\ r> [ kill-node ] "kill-node" set-word-prop

library/inference/branches.factor

@@ -73,6 +73,9 @@ sequences strings vectors words hashtables prettyprint ;
         terminate
     ] ifte* ;
 
+: unify-dataflow ( effects -- nodes )
+    [ [ dataflow-graph get ] bind ] map ;
+
 : deep-clone ( seq -- seq ) [ clone ] map ;
 
 : copy-inference ( -- )
@@ -81,7 +84,8 @@ sequences strings vectors words hashtables prettyprint ;
     meta-r [ deep-clone ] change
     meta-d [ deep-clone ] change
     d-in [ deep-clone ] change
-    dataflow-graph off ;
+    dataflow-graph off
+    current-node off ;
 
 : infer-branch ( value -- namespace )
     #! Return a namespace with inferencer variables:
@@ -92,7 +96,7 @@ sequences strings vectors words hashtables prettyprint ;
         dup value-recursion recursive-state set
         literal-value dup infer-quot
         active? [
-            #values values-node
+            #values node,
             handle-terminator
         ] [
             drop
@@ -110,23 +114,18 @@ sequences strings vectors words hashtables prettyprint ;
         ] each
     ] make-list ;
 
-: unify-dataflow ( input instruction effectlist -- )
+: infer-branches ( branches node -- )
-    [ [ get-dataflow ] bind ] map
-    swap dataflow, [ unit node-consume-d set ] bind ;
-
-: infer-branches ( input instruction branchlist -- )
     #! Recursive stack effect inference is done here. If one of
     #! the branches has an undecidable stack effect, we set the
     #! base case to this stack effect and try again.
-    (infer-branches) dup unify-effects unify-dataflow ;
+    [
-
+        >r (infer-branches) dup unify-effects unify-dataflow
-: infer-ifte ( true false -- )
+        r> set-node-children
-    #! If branch taken is computed, infer along both paths and
+    ] keep node, ;
-    #! unify.
-    2list >r pop-d \ ifte r> infer-branches ;
 
 \ ifte [
-    2 dataflow-drop, pop-d pop-d swap infer-ifte
+    2 #drop node, pop-d pop-d swap 2list
+    #ifte pop-d drop infer-branches
 ] "infer" set-word-prop
 
 : vtable>list ( rstate vtable -- list  )
@@ -134,9 +133,9 @@ sequences strings vectors words hashtables prettyprint ;
 
 USE: kernel-internals
 
-: infer-dispatch ( rstate vtable -- )
+\ dispatch [
-    >r >r pop-d \ dispatch r> r> vtable>list infer-branches ;
+    pop-literal vtable>list
-
+    #dispatch pop-d drop infer-branches
-\ dispatch [ pop-literal infer-dispatch ] "infer" set-word-prop
+] "infer" set-word-prop
 
 \ dispatch [ [ fixnum vector ] [ ] ] "infer-effect" set-word-prop

library/inference/dataflow.factor

@@ -1,87 +1,99 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: inference
-USING: interpreter kernel lists namespaces sequences vectors
+USING: generic interpreter kernel lists namespaces parser
-words ;
+sequences vectors words ;
+
+! The dataflow IR is the first of the two intermediate
+! representations used by Factor. It annotates concatenative
+! code with stack flow information and types.
+
+TUPLE: node effect param in-d out-d in-r out-r
+       successor children ;
+
+: make-node ( effect param in-d out-d in-r out-r node -- node )
+    [ >r f <node> r> set-delegate ] keep ;
+
+: NODE:
+    #! Followed by a node name.
+    scan dup [ ] define-tuple
+    create-in [ make-node ] define-constructor ; parsing
+
+: empty-node f f f f f f f f f ;
+: param-node ( label) f swap f f f f f ;
+: in-d-node ( inputs) >r f f r> f f f f ;
+: out-d-node ( outputs) >r f f f r> f f f ;
+
+: d-tail ( n -- list ) meta-d get vector-tail* ;
+: r-tail ( n -- list ) meta-r get vector-tail* ;
+
+NODE: #label
+: #label ( label -- node ) param-node <#label> ;
+
+NODE: #call
+: #call ( word -- node ) param-node <#call> ;
+
+NODE: #call-label
+: #call-label ( label -- node ) param-node <#call> ;
+
+NODE: #push
+: #push ( outputs -- node ) d-tail out-d-node <#push> ;
+
+NODE: #drop
+: #drop ( inputs -- node ) d-tail in-d-node <#drop> ;
+
+NODE: #values
+: #values ( -- node ) meta-d get >list in-d-node <#values> ;
+
+NODE: #return
+: #return ( -- node ) meta-d get >list in-d-node <#return> ;
+
+NODE: #ifte
+: #ifte ( in -- node ) 1 d-tail in-d-node <#ifte> ;
+
+NODE: #dispatch
+: #dispatch ( in -- node ) 1 d-tail in-d-node <#dispatch> ;
+
+: node-inputs ( d-count r-count node -- )
+    tuck
+    >r r-tail r> set-node-in-r
+    >r d-tail r> set-node-in-d ;
+
+: node-outputs ( d-count r-count node -- )
+    tuck
+    >r r-tail r> set-node-out-r
+    >r d-tail r> set-node-out-d ;
+
+! Variable holding dataflow graph being built.
+SYMBOL: dataflow-graph
+! The most recently added node.
+SYMBOL: current-node
+
+: node, ( node -- )
+    dataflow-graph get [
+        dup current-node [ set-node-successor ] change
+    ] [
+        ! first node
+        dup dataflow-graph set  current-node set
+    ] ifte ;
+
+: nest-node ( -- dataflow current )
+    dataflow-graph get  dataflow-graph off
+    current-node get    current-node off ;
+
+: unnest-node ( new-node dataflow current -- new-node )
+    >r >r dataflow-graph get unit over set-node-children
+    r> dataflow-graph set
+    r> current-node set ;
+
+: with-nesting ( quot -- new-node | quot: -- new-node )
+    nest-node 2slip unnest-node ; inline
+
+: copy-effect ( from to -- )
+    over node-in-d over set-node-in-d
+    over node-in-r over set-node-in-r
+    over node-out-d over set-node-out-d
+    swap node-out-r swap set-node-out-r ;
 
 ! Recursive state. An alist, mapping words to labels.
 SYMBOL: recursive-state
-
-! We build a dataflow graph for the compiler.
-SYMBOL: dataflow-graph
-
-! Label nodes have the node-label variable set.
-SYMBOL: #label
-
-SYMBOL: #call ( non-tail call )
-SYMBOL: #call-label
-SYMBOL: #push ( literal )
-SYMBOL: #drop
-
-! This is purely a marker for values we retain after a
-! conditional. It does not generate code, but merely alerts the
-! dataflow optimizer to the fact these values must be retained.
-SYMBOL: #values
-
-SYMBOL: #return
-
-SYMBOL: node-consume-d
-SYMBOL: node-produce-d
-SYMBOL: node-consume-r
-SYMBOL: node-produce-r
-SYMBOL: node-op
-SYMBOL: node-label
-
-! #push nodes have this field set to the value being pushed.
-! #call nodes have this as the word being called
-SYMBOL: node-param
-
-: <dataflow-node> ( param op -- node )
-    <namespace> [
-        node-op set
-        node-param set
-        [ ] node-consume-d set
-        [ ] node-produce-d set
-        [ ] node-consume-r set
-        [ ] node-produce-r set
-    ] extend ;
-
-: node-inputs ( d-count r-count -- )
-    #! Execute in the node's namespace.
-    meta-r get vector-tail* node-consume-r set
-    meta-d get vector-tail* node-consume-d set ;
-
-: dataflow-inputs ( in node -- )
-    [ length 0 node-inputs ] bind ;
-
-: node-outputs ( d-count r-count -- )
-    #! Execute in the node's namespace.
-    meta-r get vector-tail* node-produce-r set
-    meta-d get vector-tail* node-produce-d set ;
-
-: dataflow-outputs ( out node -- )
-    [ length 0 node-outputs ] bind ;
-
-: get-dataflow ( -- IR )
-    dataflow-graph get reverse ;
-
-: dataflow, ( param op -- node )
-    #! Add a node to the dataflow IR.
-    <dataflow-node> dup dataflow-graph [ cons ] change ;
-
-: dataflow-drop, ( n -- )
-    f #drop dataflow, [ 0 node-inputs ] bind ;
-
-: dataflow-push, ( n -- )
-    f #push dataflow, [ 0 node-outputs ] bind ;
-
-: apply-dataflow ( dataflow name default -- )
-    #! For the dataflow node, look up named word property,
-    #! if its not defined, apply default quotation to
-    #! ( node ) otherwise apply property quotation to
-    #! ( node ).
-    >r >r dup [ node-op get ] bind r> word-prop dup [
-        call r> drop
-    ] [
-        drop r> call
-    ] ifte ;

library/inference/inference.factor

@@ -18,7 +18,7 @@ SYMBOL: inferring-base-case
 SYMBOL: d-in
 
 : pop-literal ( -- rstate obj )
-    1 dataflow-drop, pop-d >literal< ;
+    1 #drop node, pop-d >literal< ;
 
 : (ensure-types) ( typelist n stack -- )
     pick [
@@ -48,6 +48,12 @@ SYMBOL: d-in
     meta-d [ append ] change
     d-in [ append ] change ;
 
+: hairy-node ( node effect quot -- )
+    over car ensure-d
+    -rot 2dup car length 0 rot node-inputs
+    2slip
+    cdr car length 0 rot node-outputs ; inline
+
 : (present-effect) ( vector -- list )
     >list [ value-class ] map ;
 
@@ -64,6 +70,7 @@ SYMBOL: d-in
     0 <vector> d-in set
     recursive-state set
     dataflow-graph off
+    current-node off
     inferring-base-case off ;
 
 GENERIC: apply-object
@@ -71,7 +78,7 @@ GENERIC: apply-object
 : apply-literal ( obj -- )
     #! Literals are annotated with the current recursive
     #! state.
-    recursive-state get <literal> push-d  1 dataflow-push, ;
+    recursive-state get <literal> push-d  1 #push node, ;
 
 M: object apply-object apply-literal ;
 
@@ -119,12 +126,6 @@ M: object apply-object apply-literal ;
         "Word leaves elements on return stack" inference-error
     ] unless ;
 
-: values-node ( op -- )
-    #! Add a #values or #return node to the graph.
-    f swap dataflow, [
-        meta-d get >list node-consume-d set
-    ] bind ;
-
 : with-infer ( quot -- )
     [
         f init-inference
@@ -133,10 +134,10 @@ M: object apply-object apply-literal ;
         check-return
     ] with-scope ;
 
-: infer ( quot -- [[ in out ]] )
+: infer ( quot -- effect )
     #! Stack effect of a quotation.
     [ infer-quot effect present-effect ] with-infer ;
 
 : dataflow ( quot -- dataflow )
     #! Data flow of a quotation.
-    [ infer-quot #return values-node get-dataflow ] with-infer ;
+    [ infer-quot #return node, dataflow-graph get ] with-infer ;

library/inference/partial-eval.factor

@@ -6,7 +6,7 @@ sequences words ;
 
 : literal-inputs? ( in stack -- )
     tail-slice dup >list [ safe-literal? ] all? [
-        length dataflow-drop, t
+        length #drop node, t
     ] [
         drop f
     ] ifte ;
@@ -16,7 +16,7 @@ sequences words ;
 
 : literal-outputs ( out stack -- )
     tail-slice dup [ recursive-state get <literal> ] nmap
-    length dataflow-push, ;
+    length #push node, ;
 
 : partial-eval? ( word -- ? )
     "infer-effect" word-prop car length

library/inference/stack.factor

@@ -4,24 +4,27 @@ IN: inference
 USING: interpreter kernel namespaces words ;
 
 \ >r [
-    f \ >r dataflow, [ 1 0 node-inputs ] extend
+    \ >r #call
+    1 0 pick node-inputs
     pop-d push-r
-    [ 0 1 node-outputs ] bind
+    0 1 pick node-outputs
+    node,
 ] "infer" set-word-prop
 
 \ r> [
-    f \ r> dataflow, [ 0 1 node-inputs ] extend
+    \ r> #call
+    0 1 pick node-inputs
     pop-r push-d
-    [ 1 0 node-outputs ] bind
+    1 0 pick node-outputs
+    node,
 ] "infer" set-word-prop
 
-: partial-eval ( word quot -- | quot: word -- )
-    >r f over dup "infer-effect" word-prop r> with-dataflow ;
-
 : infer-shuffle ( word -- )
-    [ host-word ] partial-eval ;
+    dup #call [
+        over "infer-effect" word-prop [ host-word ] hairy-node
+    ] keep node, ;
 
-\ drop [ 1 dataflow-drop, pop-d drop ] "infer" set-word-prop
+\ drop [ 1 #drop node, pop-d drop ] "infer" set-word-prop
 \ dup  [ \ dup  infer-shuffle ] "infer" set-word-prop
 \ swap [ \ swap infer-shuffle ] "infer" set-word-prop
 \ over [ \ over infer-shuffle ] "infer" set-word-prop

library/inference/words.factor

@@ -5,37 +5,24 @@ USING: errors generic interpreter kernel lists math
 math-internals namespaces sequences strings vectors words
 hashtables parser prettyprint ;
 
-: with-dataflow ( param op [[ in# out# ]] quot -- )
-    #! Take input parameters, execute quotation, take output
-    #! parameters, add node. The quotation is called with the
-    #! stack effect.
-    >r dup car ensure-d
-    >r dataflow, r> r> rot
-    [ pick car swap [ length 0 node-inputs ] bind ] keep
-    pick >r >r nip call r> r> cdr car swap
-    [ length 0 node-outputs ] bind ; inline
-
 : consume-d ( typelist -- )
     [ pop-d 2drop ] each ;
 
 : produce-d ( typelist -- )
     [ <computed> push-d ] each ;
 
-: (consume/produce) ( param op effect )
+: consume/produce ( word effect -- )
-    dup >r -rot r>
-    [ unswons consume-d car produce-d ] with-dataflow ;
-
-: consume/produce ( word [ in-types out-types ] -- )
     #! Add a node to the dataflow graph that consumes and
     #! produces a number of values.
-    over "intrinsic" word-prop [
+    swap #call [
-        f -rot
+        over [
-    ] [
+            2unlist swap consume-d produce-d
-        #call swap
+        ] hairy-node
-    ] ifte (consume/produce) ;
+    ] keep node, ;
 
 : no-effect ( word -- )
-    "Unknown stack effect: " swap word-name cat2 inference-error ;
+    "Unknown stack effect: " swap word-name append
+    inference-error ;
 
 : inhibit-parital ( -- )
     meta-d get [ f swap set-value-safe? ] each ;
@@ -43,31 +30,16 @@ hashtables parser prettyprint ;
 : recursive? ( word -- ? )
     f swap dup word-def [ = or ] tree-each-with ;
 
-: (with-block) ( [[ label quot ]] quot -- node )
+: with-block ( word [[ label quot ]] quot -- block-node )
-    #! Call a quotation in a new namespace, and transfer
-    #! inference state from the outer scope.
-    swap car >r [
-        dataflow-graph off
-        call
-        d-in get meta-d get meta-r get get-dataflow
-    ] with-scope
-    r> swap #label dataflow, [ node-label set ] extend >r
-    meta-r set meta-d set d-in set r> ;
-
-: with-block ( word [[ label quot ]] quot -- node )
     #! Execute a quotation with the word on the stack, and add
-    #! its dataflow contribution to a new block node in the IR.
+    #! its dataflow contribution to a new #label node in the IR.
-    over [
+    >r 2dup cons recursive-state [ cons ] change r>
-        >r
+    [ swap car #label slip ] with-nesting
-        dupd cons
+    recursive-state [ cdr ] change ; inline
-        recursive-state [ cons ] change
-        r> call
-    ] (with-block) ;
 
-: inline-block ( word -- effect node )
+: inline-block ( word -- node-block )
     gensym over word-def cons [
-        inhibit-parital
+        inhibit-parital  word-def infer-quot
-        word-def infer-quot effect
     ] with-block ;
 
 : inline-compound ( word -- )
@@ -75,7 +47,7 @@ hashtables parser prettyprint ;
     #! inferencer instance. If the word in question is recursive
     #! we infer its stack effect inside a new block.
     dup recursive? [
-        inline-block 2drop
+        inline-block node,
     ] [
         word-def infer-quot
     ] ifte ;
@@ -86,7 +58,7 @@ hashtables parser prettyprint ;
     [
         [
             recursive-state get init-inference
-            dup dup inline-block drop present-effect
+            dup dup inline-block drop effect present-effect
             [ "infer-effect" set-word-prop ] keep
         ] with-scope consume/produce
     ] [
@@ -153,16 +125,16 @@ M: compound apply-word ( word -- )
 
 : base-case ( word [ label quot ] -- )
     [
-        car over inline-block [
+        >r [ inline-block ] keep r> car [
-            drop
+            #call-label
-            [ #call-label ] [ #call ] ?ifte
+        ] [
-            node-op set
+            #call
-            node-param set
+        ] ?ifte [ copy-effect ] keep node,
-        ] bind
     ] with-recursion ;
 
 : no-base-case ( word -- )
-    word-name " does not have a base case." cat2 inference-error ;
+    word-name " does not have a base case." append
+    inference-error ;
 
 : recursive-word ( word [ label quot ] -- )
     #! Handle a recursive call, by either applying a previously

library/test/tuple.factor

@@ -70,3 +70,5 @@ TUPLE: circle radius ;
 M: circle area circle-radius sq pi * ;
 
 [ 200 ] [ << rect f 0 0 10 20 >> area ] unit-test
+
+[ ] [ "IN: temporary  SYMBOL: #x  TUPLE: #x ;" eval ] unit-test