Working on tuple unboxing

unfinished/compiler/tree/escape-analysis/allocations/allocations.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs namespaces sequences kernel math
-combinators sets disjoint-sets fry stack-checker.state
+combinators sets disjoint-sets fry stack-checker.state ;
-compiler.tree.copy-equiv ;
 IN: compiler.tree.escape-analysis.allocations
 
 ! A map from values to one of the following:
@@ -18,7 +17,7 @@ TUPLE: slot-access slot# value ;
 C: <slot-access> slot-access
 
 : (allocation) ( value -- value' allocations )
-    resolve-copy allocations get ; inline
+    allocations get ; inline
 
 : allocation ( value -- allocation )
     (allocation) at dup slot-access? [
@@ -26,7 +25,8 @@ C: <slot-access> slot-access
         allocation
     ] when ;
 
-: record-allocation ( allocation value -- ) (allocation) set-at ;
+: record-allocation ( allocation value -- )
+    (allocation) set-at ;
 
 : record-allocations ( allocations values -- )
     [ record-allocation ] 2each ;
@@ -40,15 +40,16 @@ SYMBOL: +escaping+
     <disjoint-set> +escaping+ over add-atom ;
 
 : init-escaping-values ( -- )
-    copies get assoc>disjoint-set +escaping+ over add-atom
+    <escaping-values> escaping-values set ;
-    escaping-values set ;
+
+: introduce-value ( values -- )
+    escaping-values get add-atom ;
+
+: introduce-values ( values -- )
+    escaping-values get add-atoms ;
 
 : <slot-value> ( -- value )
-    <value>
+    <value> dup escaping-values get add-atom ;
-    [ introduce-value ]
-    [ escaping-values get add-atom ]
-    [ ]
-    tri ;
 
 : record-slot-access ( out slot# in -- )
     over zero? [ 3drop ] [
@@ -61,8 +62,11 @@ SYMBOL: +escaping+
 : merge-slots ( values -- value )
     <slot-value> [ merge-values ] keep ;
 
+: equate-values ( value1 value2 -- )
+    escaping-values get equate ;
+
 : add-escaping-value ( value -- )
-    +escaping+ escaping-values get equate ;
+    +escaping+ equate-values ;
 
 : add-escaping-values ( values -- )
     escaping-values get
@@ -79,6 +83,20 @@ SYMBOL: +escaping+
 : escaping-value? ( value -- ? )
     +escaping+ escaping-values get equiv? ;
 
+DEFER: copy-value
+
+: copy-allocation ( allocation -- allocation' )
+    {
+        { [ dup not ] [ ] }
+        { [ dup t eq? ] [ ] }
+        [ [ <value> [ introduce-value ] [ copy-value ] [ ] tri ] map ]
+    } cond ;
+
+: copy-value ( from to -- )
+    [ equate-values ]
+    [ [ allocation copy-allocation ] dip record-allocation ]
+    2bi ;
+
 SYMBOL: escaping-allocations
 
 : compute-escaping-allocations ( -- )
@@ -88,3 +106,11 @@ SYMBOL: escaping-allocations
 
 : escaping-allocation? ( value -- ? )
     escaping-allocations get key? ;
+
+: unboxed-allocation ( value -- allocation/f )
+    dup escaping-allocation? [ drop f ] [ allocation ] if ;
+
+: unboxed-slot-access? ( value -- ? )
+    (allocation) at dup slot-access?
+    [ value>> unboxed-allocation >boolean ] [ drop f ] if ;
+

unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor

@@ -1,9 +1,9 @@
 IN: compiler.tree.escape-analysis.tests
 USING: compiler.tree.escape-analysis
 compiler.tree.escape-analysis.allocations compiler.tree.builder
-compiler.tree.normalization compiler.tree.copy-equiv
+compiler.tree.normalization math.functions
 compiler.tree.propagation compiler.tree.cleanup
-compiler.tree.combinators compiler.tree sequences math
+compiler.tree.combinators compiler.tree sequences math math.private
 kernel tools.test accessors slots.private quotations.private
 prettyprint classes.tuple.private classes classes.tuple ;
 
@@ -12,10 +12,10 @@ prettyprint classes.tuple.private classes classes.tuple ;
 GENERIC: count-unboxed-allocations* ( m node -- n )
 
 : (count-unboxed-allocations) ( m node -- n )
-    dup out-d>> first escaping-allocation? [ drop ] [ short. 1+ ] if ;
+    out-d>> first escaping-allocation? [ 1+ ] unless ;
 
 M: #call count-unboxed-allocations*
-    dup word>> \ <tuple-boa> =
+    dup word>> { <tuple-boa> <complex> } memq?
     [ (count-unboxed-allocations) ] [ drop ] if ;
 
 M: #push count-unboxed-allocations*
@@ -281,3 +281,5 @@ C: <ro-box> ro-box
     ] if ; inline recursive
 
 [ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ <complex> >rect ] count-unboxed-allocations ] unit-test

unfinished/compiler/tree/escape-analysis/escape-analysis.factor

@@ -11,6 +11,8 @@ compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.simple ;
 IN: compiler.tree.escape-analysis
 
+! This pass must run after propagation
+
 : escape-analysis ( node -- node )
     init-escaping-values
     H{ } clone allocations set

unfinished/compiler/tree/escape-analysis/nodes/nodes.factor

@@ -1,10 +1,16 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences compiler.tree ;
+USING: kernel sequences
+compiler.tree
+compiler.tree.def-use
+compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.escape-analysis.nodes
 
 GENERIC: escape-analysis* ( node -- )
 
-M: node escape-analysis* drop ;
+: (escape-analysis) ( node -- )
-
+    [
-: (escape-analysis) ( node -- ) [ escape-analysis* ] each ;
+        [ node-defs-values introduce-values ]
+        [ escape-analysis* ]
+        bi
+    ] each ;

unfinished/compiler/tree/escape-analysis/recursive/recursive-tests.factor

@@ -1,6 +1,5 @@
 IN: compiler.tree.escape-analysis.recursive.tests
 USING: kernel tools.test namespaces sequences
-compiler.tree.copy-equiv
 compiler.tree.escape-analysis.recursive
 compiler.tree.escape-analysis.allocations ;
 

unfinished/compiler/tree/escape-analysis/simple/simple.factor

@@ -1,26 +1,43 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences classes.tuple
-classes.tuple.private math math.private slots.private
+classes.tuple.private arrays math math.private slots.private
 combinators dequeues search-dequeues namespaces fry classes
-stack-checker.state
+classes.algebra stack-checker.state
 compiler.tree
 compiler.tree.propagation.info
 compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.escape-analysis.simple
 
-M: #introduce escape-analysis*
+M: #declare escape-analysis* drop ;
-    value>> unknown-allocation ;
+
+M: #terminate escape-analysis* drop ;
+
+M: #renaming escape-analysis* inputs/outputs [ copy-value ] 2each ;
+
+M: #introduce escape-analysis* value>> unknown-allocation ;
+
+DEFER: record-literal-allocation
+
+: make-literal-slots ( seq -- values )
+    [ <slot-value> [ swap record-literal-allocation ] keep ] map ;
+
+: record-literal-tuple-allocation ( value object -- )
+    tuple-slots rest-slice
+    make-literal-slots
+    swap record-allocation ;
+
+: record-literal-complex-allocation ( value object -- )
+    [ real-part ] [ imaginary-part ] bi 2array make-literal-slots
+    swap record-allocation ;
 
 : record-literal-allocation ( value object -- )
-    dup class immutable-tuple-class? [
+    {
-        tuple-slots rest-slice
+        { [ dup class immutable-tuple-class? ] [ record-literal-tuple-allocation ] }
-        [ <slot-value> [ swap record-literal-allocation ] keep ] map
+        { [ dup complex? ] [ record-literal-complex-allocation ] }
-        swap record-allocation
+        [ drop unknown-allocation ]
-    ] [
+    } cond ;
-        drop unknown-allocation
-    ] if ;
 
 M: #push escape-analysis*
     #! Delegation.
@@ -34,19 +51,29 @@ M: #push escape-analysis*
         record-allocation
     ] [ out-d>> unknown-allocations ] if ;
 
+: record-complex-allocation ( #call -- )
+    [ in-d>> ] [ out-d>> first ] bi record-allocation ;
+
+: slot-offset ( #call -- n/f )
+    dup in-d>>
+    [ first node-value-info class>> ]
+    [ second node-value-info literal>> ] 2bi
+    dup fixnum? [
+        {
+            { [ over tuple class<= ] [ 3 - ] }
+            { [ over complex class<= ] [ 1 - ] }
+            [ drop f ]
+        } cond nip
+    ] [ 2drop f ] if ;
+
 : record-slot-call ( #call -- )
-    [ out-d>> first ]
+    [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri
-    [ dup in-d>> second node-value-info literal>> ]
+    over [ record-slot-access ] [ 2drop unknown-allocation ] if ;
-    [ in-d>> first ] tri
-    over fixnum? [
-        [ 3 - ] dip record-slot-access
-    ] [
-        2drop unknown-allocation
-    ] if ;
 
 M: #call escape-analysis*
     dup word>> {
         { \ <tuple-boa> [ record-tuple-allocation ] }
+        { \ <complex> [ record-complex-allocation ] }
         { \ slot [ record-slot-call ] }
         [
             drop

unfinished/compiler/tree/optimizer/optimizer.factor

@@ -1,17 +1,22 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.tree.normalization compiler.tree.copy-equiv
+USING: compiler.tree.normalization
-compiler.tree.propagation compiler.tree.cleanup
+compiler.tree.propagation
-compiler.tree.def-use compiler.tree.untupling
+compiler.tree.cleanup
-compiler.tree.dead-code compiler.tree.strength-reduction
+compiler.tree.escape-analysis
-compiler.tree.loop-detection compiler.tree.branch-fusion ;
+compiler.tree.tuple-unboxing
+compiler.tree.def-use
+compiler.tree.dead-code
+compiler.tree.strength-reduction
+compiler.tree.loop-detection
+compiler.tree.branch-fusion ;
 IN: compiler.tree.optimizer
 
 : optimize-tree ( nodes -- nodes' )
     normalize
     propagate
     cleanup
-    compute-def-use
+    escape-analysis
     unbox-tuples
     compute-def-use
     remove-dead-code

unfinished/compiler/tree/propagation/constraints/constraints.factor

@@ -3,8 +3,9 @@
 USING: arrays assocs math math.intervals kernel accessors
 sequences namespaces classes classes.algebra
 combinators words
-compiler.tree compiler.tree.propagation.info
+compiler.tree
-compiler.tree.copy-equiv ;
+compiler.tree.propagation.info
+compiler.tree.propagation.copy ;
 IN: compiler.tree.propagation.constraints
 
 ! A constraint is a statement about a value.

unfinished/compiler/tree/propagation/copy/copy-tests.factor

@@ -1,5 +1,5 @@
-IN: compiler.tree.copy-equiv.tests
+IN: compiler.tree.propagation.copy.tests
-USING: compiler.tree.copy-equiv tools.test namespaces kernel
+USING: compiler.tree.propagation.copy tools.test namespaces kernel
 assocs ;
 
 H{ } clone copies set

unfinished/compiler/tree/propagation/copy/copy.factor

@@ -5,10 +5,7 @@ combinators sets locals
 compiler.tree
 compiler.tree.def-use
 compiler.tree.combinators ;
-IN: compiler.tree.copy-equiv
+IN: compiler.tree.propagation.copy
-
-! This is not really a compiler pass; its invoked as part of
-! propagation.
 
 ! Two values are copy-equivalent if they are always identical
 ! at run-time ("DS" relation). This is just a weak form of
@@ -39,21 +36,7 @@ SYMBOL: copies
 
 GENERIC: compute-copy-equiv* ( node -- )
 
-M: #shuffle compute-copy-equiv*
+M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ;
-    [ out-d>> dup ] [ mapping>> ] bi
-    '[ , at ] map swap are-copies-of ;
-
-M: #>r compute-copy-equiv*
-    [ in-d>> ] [ out-r>> ] bi are-copies-of ;
-
-M: #r> compute-copy-equiv*
-    [ in-r>> ] [ out-d>> ] bi are-copies-of ;
-
-M: #copy compute-copy-equiv*
-    [ in-d>> ] [ out-d>> ] bi are-copies-of ;
-
-M: #return-recursive compute-copy-equiv*
-    [ in-d>> ] [ out-d>> ] bi are-copies-of ;
 
 : compute-phi-equiv ( inputs outputs -- )
     #! An output is a copy of every input if all inputs are

unfinished/compiler/tree/propagation/info/info.factor

@@ -3,7 +3,7 @@
 USING: assocs classes classes.algebra kernel
 accessors math math.intervals namespaces sequences words
 combinators combinators.short-circuit arrays
-compiler.tree.copy-equiv ;
+compiler.tree.propagation.copy ;
 IN: compiler.tree.propagation.info
 
 : false-class? ( class -- ? ) \ f class<= ;

unfinished/compiler/tree/propagation/nodes/nodes.factor

@@ -3,7 +3,7 @@
 USING: sequences accessors kernel assocs sequences
 compiler.tree
 compiler.tree.def-use
-compiler.tree.copy-equiv
+compiler.tree.propagation.copy
 compiler.tree.propagation.info ;
 IN: compiler.tree.propagation.nodes
 

unfinished/compiler/tree/propagation/propagation.factor

@@ -3,7 +3,7 @@
 USING: accessors kernel sequences namespaces hashtables
 compiler.tree
 compiler.tree.def-use
-compiler.tree.copy-equiv
+compiler.tree.propagation.copy
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
 compiler.tree.propagation.simple
@@ -13,6 +13,8 @@ compiler.tree.propagation.constraints
 compiler.tree.propagation.known-words ;
 IN: compiler.tree.propagation
 
+! This pass must run after normalization
+
 : propagate ( node -- node )
     H{ } clone copies set
     H{ } clone constraints set

unfinished/compiler/tree/propagation/recursive/recursive.factor

@@ -4,8 +4,8 @@ USING: kernel sequences accessors arrays fry math.intervals
 combinators namespaces
 stack-checker.inlining
 compiler.tree
-compiler.tree.copy-equiv
 compiler.tree.combinators
+compiler.tree.propagation.copy
 compiler.tree.propagation.info
 compiler.tree.propagation.nodes
 compiler.tree.propagation.simple

unfinished/compiler/tree/tree.factor

@@ -39,7 +39,9 @@ TUPLE: #push < node literal out-d ;
         swap 1array >>out-d
         swap >>literal ;
 
-TUPLE: #shuffle < node mapping in-d out-d ;
+TUPLE: #renaming < node ;
+
+TUPLE: #shuffle < #renaming mapping in-d out-d ;
 
 : #shuffle ( inputs outputs mapping -- node )
     \ #shuffle new
@@ -50,14 +52,14 @@ TUPLE: #shuffle < node mapping in-d out-d ;
 : #drop ( inputs -- node )
     { } { } #shuffle ;
 
-TUPLE: #>r < node in-d out-r ;
+TUPLE: #>r < #renaming in-d out-r ;
 
 : #>r ( inputs outputs -- node )
     \ #>r new
         swap >>out-r
         swap >>in-d ;
 
-TUPLE: #r> < node in-r out-d ;
+TUPLE: #r> < #renaming in-r out-d ;
 
 : #r> ( inputs outputs -- node )
     \ #r> new
@@ -126,7 +128,7 @@ TUPLE: #enter-recursive < node in-d out-d label ;
         swap >>in-d
         swap >>label ;
 
-TUPLE: #return-recursive < node in-d out-d label ;
+TUPLE: #return-recursive < #renaming in-d out-d label ;
 
 : #return-recursive ( label inputs outputs -- node )
     \ #return-recursive new
@@ -134,7 +136,7 @@ TUPLE: #return-recursive < node in-d out-d label ;
         swap >>in-d
         swap >>label ;
 
-TUPLE: #copy < node in-d out-d ;
+TUPLE: #copy < #renaming in-d out-d ;
 
 : #copy ( inputs outputs -- node )
     \ #copy new
@@ -143,6 +145,14 @@ TUPLE: #copy < node in-d out-d ;
 
 : node, ( node -- ) stack-visitor get push ;
 
+GENERIC: inputs/outputs ( #renaming -- inputs outputs )
+
+M: #shuffle inputs/outputs mapping>> unzip swap ;
+M: #>r inputs/outputs [ in-d>> ] [ out-r>> ] bi ;
+M: #r> inputs/outputs [ in-r>> ] [ out-d>> ] bi ;
+M: #copy inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
+M: #return-recursive inputs/outputs [ in-d>> ] [ out-d>> ] bi ;
+
 M: vector child-visitor V{ } clone ;
 M: vector #introduce, #introduce node, ;
 M: vector #call, #call node, ;

unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor

@@ -0,0 +1,109 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.tree.tuple-unboxing
+
+! This pass must run after escape analysis
+
+! Mapping from values to sequences of values
+SYMBOL: unboxed-tuples
+
+: unboxed-tuple ( value -- unboxed-tuple )
+    unboxed-tuples get at ;
+
+GENERIC: unbox-tuples* ( node -- )
+
+: value-info-slots ( info -- slots )
+    #! Delegation.
+    [ info>> ] [ class>> ] bi {
+        { [ dup tuple class<= ] [ drop 2 tail ] }
+        { [ dup complex class<= ] [ drop ] }
+    } cond ;
+
+: prepare-unboxed-values ( #push -- values )
+    out-d>> first unboxed-allocation ;
+
+: prepare-unboxed-info ( #push -- infos values )
+    dup prepare-unboxed-values dup
+    [ [ node-output-infos first value-info-slots ] dip ]
+    [ 2drop f f ]
+    if ;
+
+: expand-#push ( #push infos values -- )
+    [ [ literal>> ] dip #push ] 2map >>body drop ;
+
+M: #push unbox-tuples* ( #push -- )
+    dup prepare-unboxed-info dup [ expand-#push ] [ 3drop ] if ;
+
+: expand-<tuple-boa> ( #call values -- quot )
+    [ drop in-d>> peek #drop ]
+    [ [ in-d>> but-last ] dip #copy ]
+    2bi 2array ;
+
+: expand-<complex> ( #call values -- quot )
+    [ in-d>> ] dip #copy 1array ;
+
+: expand-constructor ( #call values -- )
+    [ drop ] [ ] [ drop word>> ] 2tri {
+        { <tuple-boa> [ expand-<tuple-boa> ] }
+        { <complex> [ expand-<complex> ] }
+    } case unbox-tuples >>body ;
+
+: unbox-constructor ( #call -- )
+    dup prepare-unboxed-values dup
+    [ expand-constructor ] [ 2drop ] if ;
+
+: (flatten-values) ( values -- values' )
+    [ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ;
+
+: flatten-values ( values -- values' )
+    (flatten-values) flatten ;
+
+: flatten-value ( values -- values )
+    1array flatten-values ;
+
+: prepare-slot-access ( #call -- tuple-values slot-values outputs )
+    [ in-d>> first flatten-value ]
+    [
+        [ dup in-d>> second node-value-info literal>> ]
+        [ out-d>> first unboxed-allocation ]
+        bi nth flatten-value
+    ]
+    [ out-d>> flatten-values ]
+    tri ;
+
+: slot-access-shuffle ( tuple-values slot-values outputs -- #shuffle )
+    [ nip ] [ zip ] 2bi #shuffle ;
+
+: unbox-slot-access ( #call -- )
+    dup unboxed-slot-access? [
+        dup
+        [ in-d>> second 1array #drop ]
+        [ prepare-slot-access slot-access-shuffle ]
+        bi 2array unbox-tuples >>body
+    ] when drop ;
+
+M: #call unbox-tuples* ( #call -- )
+    dup word>> {
+        { \ <tuple-boa> [ unbox-<tuple-boa> ] }
+        { \ <complex> [ unbox-<complex> ] }
+        { \ slot [ unbox-slot-access ] }
+        [ 2drop ]
+    } case ;
+
+M: #copy ... ;
+
+M: #>r ... ;
+
+M: #r> ... ;
+
+M: #shuffle ... ;
+
+M: #terrible ... ;
+
+! These nodes never participate in unboxing
+M: #return drop ;
+
+M: #introduce drop ;
+
+: unbox-tuples ( nodes -- nodes )
+    dup [ unbox-tuples* ] each-node ;

unfinished/compiler/tree/untupling/untupling-tests.factor

@@ -1,50 +0,0 @@
-IN: compiler.tree.untupling.tests
-USING: assocs math kernel quotations.private slots.private
-compiler.tree.builder
-compiler.tree.def-use
-compiler.tree.copy-equiv
-compiler.tree.untupling
-tools.test ;
-
-: check-untupling ( quot -- sizes )
-    build-tree
-    compute-copy-equiv
-    compute-def-use
-    compute-untupling
-    values ;
-
-[ { } ] [ [ 1 [ + ] curry ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 1 [ + ] curry drop ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 1 [ + ] curry 3 slot ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 1 [ + ] curry 3 slot drop ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 1 [ + ] curry uncurry ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test
-
-[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test
-
-[ { } ] [ [ [ 1 [ + ] curry ] [ [ ] ] if ] check-untupling ] unit-test
-
-[ { 2 2 } ] [
-    [ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if uncurry ] check-untupling
-] unit-test
-
-[ { } ] [
-    [ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if ] check-untupling
-] unit-test
-
-[ { 2 2 2 } ] [
-    [ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if uncurry ] check-untupling
-] unit-test
-
-[ { 2 2 } ] [
-    [ [ 1 [ + ] curry 4 ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if uncurry ] if ] check-untupling
-] unit-test
-
-[ { } ] [
-    [ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if ] check-untupling
-] unit-test

unfinished/compiler/tree/untupling/untupling.factor

@@ -1,59 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors slots.private kernel namespaces disjoint-sets
-math sequences assocs classes.tuple.private combinators fry sets
-compiler.tree compiler.tree.combinators compiler.tree.copy-equiv
-compiler.tree.dataflow-analysis
-compiler.tree.dataflow-analysis.backward ;
-IN: compiler.tree.untupling
-
-SYMBOL: escaping-values
-
-: mark-escaping-values ( node -- )
-    in-d>> escaping-values get '[ resolve-copy , conjoin ] each ;
-
-SYMBOL: untupling-candidates
-
-: untupling-candidate ( #call class -- )
-    #! 1- for delegate
-    size>> 1- swap out-d>> first resolve-copy
-    untupling-candidates get set-at ;
-
-GENERIC: compute-untupling* ( node -- )
-
-M: #call compute-untupling*
-    dup word>> {
-        { \ <tuple-boa> [ dup in-d>> peek untupling-candidate ] }
-        { \ curry [ \ curry tuple-layout untupling-candidate ] }
-        { \ compose [ \ compose tuple-layout untupling-candidate ] }
-        { \ slot [ drop ] }
-        [ drop mark-escaping-values ]
-    } case ;
-
-M: #return compute-untupling* mark-escaping-values ;
-
-M: node compute-untupling* drop ;
-
-GENERIC: check-consistency* ( node -- )
-
-: check-value-consistency ( out-value in-values -- )
-    swap escaping-values get key? [
-        escaping-values get '[ , conjoin ] each
-    ] [
-        untupling-candidates get 2dup '[ , at ] map all-equal?
-        [ 2drop ] [ '[ , delete-at ] each ] if
-    ] if ;
-
-M: #phi check-consistency*
-    [ [ out-d>> ] [ phi-in-d>> ] bi [ check-value-consistency ] 2each ]
-    [ [ out-r>> ] [ phi-in-r>> ] bi [ check-value-consistency ] 2each ]
-    bi ;
-
-M: node check-consistency* drop ;
-
-: compute-untupling ( node -- assoc )
-    H{ } clone escaping-values set
-    H{ } clone untupling-candidates set
-    [ [ compute-untupling* ] each-node ]
-    [ [ check-consistency* ] each-node ] bi
-    untupling-candidates get escaping-values get assoc-diff ;