Tuple unboxing progress

basis/disjoint-sets/disjoint-sets.factor

@@ -66,6 +66,10 @@ M: disjoint-set add-atom
 
 : add-atoms ( seq disjoint-set -- ) '[ , add-atom ] each ;
 
+GENERIC: disjoint-set-member? ( a disjoint-set -- ? )
+
+M: disjoint-set disjoint-set-member? parents>> key? ;
+
 GENERIC: equiv-set-size ( a disjoint-set -- n )
 
 M: disjoint-set equiv-set-size [ representative ] keep count ;

unfinished/compiler/tree/cleanup/cleanup.factor

@@ -2,8 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors sequences sequences.deep combinators fry
 classes.algebra namespaces assocs math math.private
-math.partial-dispatch
+math.partial-dispatch classes.tuple classes.tuple.private
 compiler.tree
+compiler.tree.intrinsics
 compiler.tree.combinators
 compiler.tree.propagation.info
 compiler.tree.propagation.branches ;
@@ -53,11 +54,21 @@ GENERIC: cleanup* ( node -- node/nodes )
 : remove-overflow-check ( #call -- #call )
     [ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
 
+: immutable-tuple-boa? ( #call -- ? )
+    dup word>> \ <tuple-boa> eq? [
+        dup in-d>> peek node-value-info
+        literal>> class>> immutable-tuple-class?
+    ] [ drop f ] if ;
+
+: immutable-tuple-boa ( #call -- #call )
+    \ <immutable-tuple-boa> >>word ;
+
 M: #call cleanup*
     {
         { [ dup body>> ] [ cleanup-inlining ] }
         { [ dup cleanup-folding? ] [ cleanup-folding ] }
         { [ dup remove-overflow-check? ] [ remove-overflow-check ] }
+        { [ dup immutable-tuple-boa? ] [ immutable-tuple-boa ] }
         [ ]
     } cond ;
 

unfinished/compiler/tree/dead-code/dead-code-tests.factor

@@ -1,7 +1,7 @@
 USING: namespaces assocs sequences compiler.tree.builder
 compiler.tree.dead-code compiler.tree.def-use compiler.tree
 compiler.tree.combinators tools.test kernel math
-stack-checker.state accessors ;
+stack-checker.state accessors combinators ;
 IN: compiler.tree.dead-code.tests
 
 \ remove-dead-code must-infer
@@ -10,20 +10,27 @@ IN: compiler.tree.dead-code.tests
     build-tree
     compute-def-use
     remove-dead-code
-    compute-def-use
+    0 swap [
-    0 swap [ dup #push? [ out-d>> length + ] [ drop ] if ] each-node ;
+        {
+            { [ dup #push? ] [ out-d>> length + ] }
+            { [ dup #introduce? ] [ drop 1 + ] }
+            [ drop ]
+        } cond
+    ] each-node ;
 
 [ 3 ] [ [ 1 2 3 ] count-live-values ] unit-test
 
+[ 1 ] [ [ drop ] count-live-values ] unit-test
+
 [ 0 ] [ [ 1 drop ] count-live-values ] unit-test
 
 [ 1 ] [ [ 1 2 drop ] count-live-values ] unit-test
 
-[ 2 ] [ [ [ 1 ] [ 2 ] if ] count-live-values ] unit-test
+[ 3 ] [ [ [ 1 ] [ 2 ] if ] count-live-values ] unit-test
 
-[ 0 ] [ [ [ 1 ] [ 2 ] if drop ] count-live-values ] unit-test
+[ 1 ] [ [ [ 1 ] [ 2 ] if drop ] count-live-values ] unit-test
 
-[ 0 ] [ [ [ 1 ] [ dup ] if drop ] count-live-values ] unit-test
+[ 2 ] [ [ [ 1 ] [ dup ] if drop ] count-live-values ] unit-test
 
 [ 2 ] [ [ 1 2 + ] count-live-values ] unit-test
 
@@ -33,9 +40,9 @@ IN: compiler.tree.dead-code.tests
 
 [ 0 ] [ [ 1 2 + 3 + drop ] count-live-values ] unit-test
 
-[ 3 ] [ [ [ 1 ] [ 2 ] if 3 + ] count-live-values ] unit-test
+[ 4 ] [ [ [ 1 ] [ 2 ] if 3 + ] count-live-values ] unit-test
 
-[ 0 ] [ [ [ 1 ] [ 2 ] if 3 + drop ] count-live-values ] unit-test
+[ 1 ] [ [ [ 1 ] [ 2 ] if 3 + drop ] count-live-values ] unit-test
 
 [ 0 ] [ [ [ ] call ] count-live-values ] unit-test
 

unfinished/compiler/tree/dead-code/dead-code.factor

@@ -3,15 +3,18 @@
 USING: fry accessors namespaces assocs dequeues search-dequeues
 kernel sequences words sets stack-checker.inlining
 compiler.tree
+compiler.tree.combinators
 compiler.tree.dataflow-analysis
-compiler.tree.dataflow-analysis.backward
+compiler.tree.dataflow-analysis.backward ;
-compiler.tree.combinators ;
 IN: compiler.tree.dead-code
 
 ! Dead code elimination: remove #push and flushable #call whose
 ! outputs are unused using backward DFA.
 GENERIC: mark-live-values ( node -- )
 
+M: #introduce mark-live-values
+    value>> look-at-value ;
+
 M: #if mark-live-values look-at-inputs ;
 
 M: #dispatch mark-live-values look-at-inputs ;
@@ -34,9 +37,6 @@ SYMBOL: live-values
 
 GENERIC: remove-dead-values* ( node -- )
 
-M: #introduce remove-dead-values*
-    [ [ live-value? ] filter ] change-values drop ;
-
 M: #>r remove-dead-values*
     dup out-r>> first live-value? [ { } >>out-r ] unless
     dup in-d>> first live-value? [ { } >>in-d ] unless
@@ -57,6 +57,30 @@ M: #push remove-dead-values*
 : filter-live ( values -- values' )
     [ live-value? ] filter ;
 
+M: #call remove-dead-values*
+    [ filter-live ] change-in-d
+    [ filter-live ] change-out-d
+    drop ;
+
+M: #recursive remove-dead-values*
+    [ filter-live ] change-in-d
+    drop ;
+
+M: #call-recursive remove-dead-values*
+    [ filter-live ] change-in-d
+    [ filter-live ] change-out-d
+    drop ;
+
+M: #enter-recursive remove-dead-values*
+    [ filter-live ] change-in-d
+    [ filter-live ] change-out-d
+    drop ;
+
+M: #return-recursive remove-dead-values*
+    [ filter-live ] change-in-d
+    [ filter-live ] change-out-d
+    drop ;
+
 M: #shuffle remove-dead-values*
     [ filter-live ] change-in-d
     [ filter-live ] change-out-d
@@ -92,24 +116,19 @@ M: #phi remove-dead-values*
 
 M: node remove-dead-values* drop ;
 
-M: f remove-dead-values* drop ;
+: remove-dead-values ( nodes -- )
+    [ remove-dead-values* ] each-node ;
 
-GENERIC: remove-dead-nodes* ( node -- newnode/t )
+GENERIC: remove-dead-nodes* ( node -- node/f )
 
-: prune-if-empty ( node seq -- successor/t )
+: prune-if-empty ( node seq -- node/f )
-    empty? [ successor>> ] [ drop t ] if ; inline
+    empty? [ drop f ] when ; inline
 
-M: #introduce remove-dead-nodes* dup values>> prune-if-empty ;
+: live-call? ( #call -- ? ) out-d>> [ live-value? ] contains? ;
-
-: live-call? ( #call -- ? )
-    out-d>> [ live-value? ] contains? ;
 
 M: #declare remove-dead-nodes* dup declaration>> prune-if-empty ;
 
-M: #call remove-dead-nodes*
+M: #call remove-dead-nodes* dup live-call? [ in-d>> #drop ] unless ;
-    dup live-call? [ drop t ] [
-        [ in-d>> #drop ] [ successor>> ] bi >>successor
-    ] if ;
 
 M: #shuffle remove-dead-nodes* dup in-d>> prune-if-empty ;
 
@@ -121,25 +140,13 @@ M: #r> remove-dead-nodes* dup in-r>> prune-if-empty ;
 
 M: #copy remove-dead-nodes* dup in-d>> prune-if-empty ;
 
-: (remove-dead-code) ( node -- newnode )
+M: node remove-dead-nodes* ;
-    [
-        dup remove-dead-values*
-        dup remove-dead-nodes* dup t eq?
-        [ drop ] [ nip (remove-dead-code) ] if
-    ] transform-nodes ;
 
-M: #if remove-dead-nodes*
+: remove-dead-nodes ( nodes -- nodes' )
-    [ (remove-dead-code) ] map-children t ;
+    [ remove-dead-nodes* ] map-nodes ;
-
-M: #dispatch remove-dead-nodes*
-    [ (remove-dead-code) ] map-children t ;
-
-M: #recursive remove-dead-nodes*
-    [ (remove-dead-code) ] change-child drop t ;
-
-M: node remove-dead-nodes* drop t ;
-
-M: f remove-dead-nodes* drop t ;
 
 : remove-dead-code ( node -- newnode )
-    [ [ compute-live-values ] [ (remove-dead-code) ] bi ] with-scope ;
+    [ compute-live-values ]
+    [ remove-dead-values ]
+    [ remove-dead-nodes ]
+    tri ;

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

@@ -9,21 +9,13 @@ IN: compiler.tree.escape-analysis.allocations
 !        may potentially become an allocation later
 ! - a sequence of values -- potentially unboxed tuple allocations
 ! - t -- not allocated in this procedure, can never be unboxed
-
 SYMBOL: allocations
 
-TUPLE: slot-access slot# value ;
-
-C: <slot-access> slot-access
-
 : (allocation) ( value -- value' allocations )
     allocations get ; inline
 
 : allocation ( value -- allocation )
-    (allocation) at dup slot-access? [
+    (allocation) at ;
-        [ slot#>> ] [ value>> allocation ] bi nth
-        allocation
-    ] when ;
 
 : record-allocation ( allocation value -- )
     (allocation) set-at ;
@@ -31,6 +23,17 @@ C: <slot-access> slot-access
 : record-allocations ( allocations values -- )
     [ record-allocation ] 2each ;
 
+! We track slot access to connect constructor inputs with
+! accessor outputs.
+SYMBOL: slot-accesses
+
+TUPLE: slot-access slot# value ;
+
+C: <slot-access> slot-access
+
+: record-slot-access ( out slot# in -- )
+    <slot-access> swap slot-accesses get set-at ;
+
 ! We track escaping values with a disjoint set.
 SYMBOL: escaping-values
 
@@ -43,18 +46,15 @@ SYMBOL: +escaping+
     <escaping-values> escaping-values set ;
 
 : introduce-value ( values -- )
-    escaping-values get add-atom ;
+    escaping-values get
+    2dup disjoint-set-member?
+    [ 2drop ] [ add-atom ] if ;
 
 : introduce-values ( values -- )
-    escaping-values get add-atoms ;
+    [ introduce-value ] each ;
 
 : <slot-value> ( -- value )
-    <value> dup escaping-values get add-atom ;
+    <value> dup introduce-value ;
-
-: record-slot-access ( out slot# in -- )
-    over zero? [ 3drop ] [
-        <slot-access> swap record-allocation
-    ] if ;
 
 : merge-values ( in-values out-value -- )
     escaping-values get '[ , , equate ] each ;
@@ -66,11 +66,17 @@ SYMBOL: +escaping+
     escaping-values get equate ;
 
 : add-escaping-value ( value -- )
-    +escaping+ equate-values ;
+    [
+        allocation {
+            { [ dup not ] [ drop ] }
+            { [ dup t eq? ] [ drop ] }
+            [ [ add-escaping-value ] each ]
+        } cond
+    ]
+    [ +escaping+ equate-values ] bi ;
 
 : add-escaping-values ( values -- )
-    escaping-values get
+    [ add-escaping-value ] each ;
-    '[ +escaping+ , equate ] each ;
 
 : unknown-allocation ( value -- )
     [ add-escaping-value ]
@@ -97,6 +103,14 @@ DEFER: copy-value
     [ [ allocation copy-allocation ] dip record-allocation ]
     2bi ;
 
+: copy-slot-value ( out slot# in -- )
+    allocation {
+        { [ dup not ] [ 3drop ] }
+        { [ dup t eq? ] [ 3drop ] }
+        [ nth swap copy-value ]
+    } cond ;
+
+! Compute which tuples escape
 SYMBOL: escaping-allocations
 
 : compute-escaping-allocations ( -- )
@@ -111,6 +125,5 @@ SYMBOL: escaping-allocations
     dup escaping-allocation? [ drop f ] [ allocation ] if ;
 
 : unboxed-slot-access? ( value -- ? )
-    (allocation) at dup slot-access?
+    slot-accesses get at*
-    [ value>> unboxed-allocation >boolean ] [ drop f ] if ;
+    [ value>> unboxed-allocation >boolean ] when ;
-

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

@@ -217,6 +217,11 @@ C: <ro-box> ro-box
 
 [ 3 ] [ [ <ro-box> tuple-fib ] count-unboxed-allocations ] unit-test
 
+: tuple-fib' ( m -- n )
+    dup 1 <= [ 1- tuple-fib' i>> ] when <ro-box> ; inline recursive
+
+[ 0 ] [ [ tuple-fib' ] count-unboxed-allocations ] unit-test
+
 : bad-tuple-fib-1 ( m -- n )
     dup i>> 1 <= [
         drop 1 <ro-box>
@@ -283,3 +288,9 @@ C: <ro-box> ro-box
 [ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
 
 [ 1 ] [ [ <complex> >rect ] count-unboxed-allocations ] unit-test
+
+[ 0 ] [ [ 1 cons boa 2 cons boa ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ 1 cons boa 2 cons boa car>> ] count-unboxed-allocations ] unit-test
+
+[ 0 ] [ [ 1 cons boa 2 cons boa dup . car>> ] count-unboxed-allocations ] unit-test

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

@@ -16,5 +16,6 @@ IN: compiler.tree.escape-analysis
 : escape-analysis ( node -- node )
     init-escaping-values
     H{ } clone allocations set
+    H{ } clone slot-accesses set
     dup (escape-analysis)
     compute-escaping-allocations ;

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

@@ -4,7 +4,7 @@ compiler.tree.escape-analysis.recursive
 compiler.tree.escape-analysis.allocations ;
 
 H{ } clone allocations set
-H{ } clone copies set
+<escaping-values> escaping-values set
 
 [ ] [ 8 [ introduce-value ] each ] unit-test
 

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

@@ -29,10 +29,12 @@ IN: compiler.tree.escape-analysis.recursive
     out-d>> [ allocation ] map ;
 
 : recursive-stacks ( #enter-recursive -- stacks )
-    [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
+    [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix
+    escaping-values get '[ [ , disjoint-set-member? ] all? ] filter
+    flip ;
 
 : analyze-recursive-phi ( #enter-recursive -- )
-    [ ] [ recursive-stacks flip ] [ out-d>> ] tri
+    [ ] [ recursive-stacks ] [ out-d>> ] tri
     [ [ merge-values ] 2each ]
     [
         [ (merge-allocations) ] dip
@@ -44,11 +46,16 @@ IN: compiler.tree.escape-analysis.recursive
 M: #recursive escape-analysis* ( #recursive -- )
     [
         child>>
+        [ first out-d>> introduce-values ]
         [ first analyze-recursive-phi ]
         [ (escape-analysis) ]
-        bi
+        tri
     ] until-fixed-point ;
 
+M: #enter-recursive escape-analysis* ( #enter-recursive -- )
+    #! Handled by #recursive
+    drop ;
+
 : return-allocations ( node -- allocations )
     label>> return>> node-input-allocations ;
 
@@ -57,5 +64,8 @@ M: #call-recursive escape-analysis* ( #call-label -- )
     [ check-fixed-point ] [ drop swap out-d>> record-allocations ] 3bi ;
 
 M: #return-recursive escape-analysis* ( #return-recursive -- )
+    [ call-next-method ]
+    [
         [ in-d>> ] [ label>> calls>> ] bi
-    [ out-d>> escaping-values get '[ , equate ] 2each ] with each ;
+        [ out-d>> escaping-values get '[ , equate ] 2each ] with each
+    ] bi ;

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

@@ -5,6 +5,7 @@ classes.tuple.private arrays math math.private slots.private
 combinators dequeues search-dequeues namespaces fry classes
 classes.algebra stack-checker.state
 compiler.tree
+compiler.tree.intrinsics
 compiler.tree.propagation.info
 compiler.tree.escape-analysis.nodes
 compiler.tree.escape-analysis.allocations ;
@@ -23,33 +24,24 @@ DEFER: record-literal-allocation
 : make-literal-slots ( seq -- values )
     [ <slot-value> [ swap record-literal-allocation ] keep ] map ;
 
-: record-literal-tuple-allocation ( value object -- )
+: object-slots ( object -- slots/f )
-    tuple-slots rest-slice
+    #! Delegation
-    make-literal-slots
+    {
-    swap record-allocation ;
+        { [ dup class immutable-tuple-class? ] [ tuple-slots rest-slice ] }
-
+        { [ dup complex? ] [ [ real-part ] [ imaginary-part ] bi 2array ] }
-: record-literal-complex-allocation ( value object -- )
+        [ drop f ]
-    [ real-part ] [ imaginary-part ] bi 2array make-literal-slots
+    } cond ;
-    swap record-allocation ;
 
 : record-literal-allocation ( value object -- )
-    {
+    object-slots dup
-        { [ dup class immutable-tuple-class? ] [ record-literal-tuple-allocation ] }
+    [ make-literal-slots swap record-allocation ] [ 2drop ] if ;
-        { [ dup complex? ] [ record-literal-complex-allocation ] }
-        [ drop unknown-allocation ]
-    } cond ;
 
 M: #push escape-analysis*
     #! Delegation.
     [ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
 
 : record-tuple-allocation ( #call -- )
-    #! Delegation.
+    [ in-d>> but-last ] [ out-d>> first ] bi record-allocation ;
-    dup dup in-d>> peek node-value-info literal>>
-    class>> immutable-tuple-class? [
-        [ in-d>> but-last ] [ out-d>> first ] bi
-        record-allocation
-    ] [ out-d>> unknown-allocations ] if ;
 
 : record-complex-allocation ( #call -- )
     [ in-d>> ] [ out-d>> first ] bi record-allocation ;
@@ -68,11 +60,13 @@ M: #push escape-analysis*
 
 : record-slot-call ( #call -- )
     [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri
-    over [ record-slot-access ] [ 2drop unknown-allocation ] if ;
+    over [
+        [ record-slot-access ] [ copy-slot-value ] 3bi
+    ] [ 2drop unknown-allocation ] if ;
 
 M: #call escape-analysis*
     dup word>> {
-        { \ <tuple-boa> [ record-tuple-allocation ] }
+        { \ <immutable-tuple-boa> [ record-tuple-allocation ] }
         { \ <complex> [ record-complex-allocation ] }
         { \ slot [ record-slot-call ] }
         [

unfinished/compiler/tree/intrinsics/intrinsics.factor

@@ -0,0 +1,6 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel ;
+IN: compiler.tree.intrinsics
+
+: <immutable-tuple-boa> ( ... class -- tuple ) "Intrinsic" throw ;

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

@@ -0,0 +1,31 @@
+IN: compiler.tree.tuple-unboxing.tests
+USING: tools.test compiler.tree.tuple-unboxing
+compiler.tree compiler.tree.builder compiler.tree.normalization
+compiler.tree.propagation compiler.tree.cleanup
+compiler.tree.escape-analysis compiler.tree.tuple-unboxing
+compiler.tree.def-use kernel accessors sequences math ;
+
+\ unbox-tuples must-infer
+
+: test-unboxing ( quot -- )
+    #! Just make sure it doesn't throw errors; compute def use
+    #! for kicks.
+    build-tree
+    normalize
+    propagate
+    cleanup
+    escape-analysis
+    unbox-tuples
+    compute-def-use
+    drop ;
+
+TUPLE: cons { car read-only } { cdr read-only } ;
+
+TUPLE: empty-tuple ;
+
+{
+    [ empty-tuple boa drop ]
+    [ cons boa [ car>> ] [ cdr>> ] bi ]
+    [ [ 1 cons boa ] [ 2 cons boa ] if car>> ]
+    [ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ]
+} [ [ ] swap [ test-unboxing ] curry unit-test ] each

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

@@ -1,56 +1,41 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces assocs accessors kernel combinators
+classes.algebra sequences sequences.deep slots.private
+classes.tuple.private math math.private arrays
+compiler.tree
+compiler.tree.intrinsics
+compiler.tree.combinators
+compiler.tree.escape-analysis.simple
+compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.tuple-unboxing
 
 ! This pass must run after escape analysis
 
-! Mapping from values to sequences of values
+GENERIC: unbox-tuples* ( node -- node/nodes )
-SYMBOL: unboxed-tuples
 
-: unboxed-tuple ( value -- unboxed-tuple )
+: unbox-output? ( node -- values )
-    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 )
+: (expand-#push) ( object value -- nodes )
-    dup prepare-unboxed-values dup
+    dup unboxed-allocation dup [
-    [ [ node-output-infos first value-info-slots ] dip ]
+        [ object-slots ] [ drop ] [ ] tri*
-    [ 2drop f f ]
+        [ (expand-#push) ] 2map
-    if ;
+    ] [
+        drop #push
+    ] if ;
 
-: expand-#push ( #push infos values -- )
+: expand-#push ( #push -- nodes )
-    [ [ literal>> ] dip #push ] 2map >>body drop ;
+    [ literal>> ] [ out-d>> first ] bi (expand-#push) ;
 
-M: #push unbox-tuples* ( #push -- )
+M: #push unbox-tuples* ( #push -- nodes )
-    dup prepare-unboxed-info dup [ expand-#push ] [ 3drop ] if ;
+    dup unbox-output? [ expand-#push ] when ;
 
-: expand-<tuple-boa> ( #call values -- quot )
+: unbox-<tuple-boa> ( #call -- nodes )
-    [ drop in-d>> peek #drop ]
+    dup unbox-output? [ in-d>> 1 tail* #drop ] when ;
-    [ [ in-d>> but-last ] dip #copy ]
-    2bi 2array ;
 
-: expand-<complex> ( #call values -- quot )
+: unbox-<complex> ( #call -- nodes )
-    [ in-d>> ] dip #copy 1array ;
+    dup unbox-output? [ drop { } ] when ;
-
-: 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 ;
@@ -59,51 +44,57 @@ M: #push unbox-tuples* ( #push -- )
     (flatten-values) flatten ;
 
 : flatten-value ( values -- values )
-    1array flatten-values ;
+    [ unboxed-allocation ] [ 1array ] bi or ;
 
-: prepare-slot-access ( #call -- tuple-values slot-values outputs )
+: prepare-slot-access ( #call -- tuple-values outputs slot-values )
     [ 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 ;
+    [
+        out-d>> first slot-accesses get at
+        [ slot#>> ] [ value>> ] bi allocation nth flatten-value
+    ] tri ;
 
-: slot-access-shuffle ( tuple-values slot-values outputs -- #shuffle )
+: slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle )
-    [ nip ] [ zip ] 2bi #shuffle ;
+    [ drop ] [ zip ] 2bi #shuffle ;
 
-: unbox-slot-access ( #call -- )
+: unbox-slot-access ( #call -- nodes )
-    dup unboxed-slot-access? [
+    dup out-d>> first unboxed-slot-access? [
-        dup
         [ in-d>> second 1array #drop ]
         [ prepare-slot-access slot-access-shuffle ]
-        bi 2array unbox-tuples >>body
+        bi 2array
-    ] when drop ;
+    ] when ;
 
-M: #call unbox-tuples* ( #call -- )
+M: #call unbox-tuples*
     dup word>> {
-        { \ <tuple-boa> [ unbox-<tuple-boa> ] }
+        { \ <immutable-tuple-boa> [ unbox-<tuple-boa> ] }
         { \ <complex> [ unbox-<complex> ] }
         { \ slot [ unbox-slot-access ] }
-        [ 2drop ]
+        [ drop ]
     } case ;
 
-M: #copy ... ;
+M: #copy unbox-tuples*
+    [ flatten-values ] change-in-d
+    [ flatten-values ] change-out-d ;
 
-M: #>r ... ;
+M: #>r unbox-tuples*
+    [ flatten-values ] change-in-d
+    [ flatten-values ] change-out-r ;
 
-M: #r> ... ;
+M: #r> unbox-tuples*
+    [ flatten-values ] change-in-r
+    [ flatten-values ] change-out-d ;
 
-M: #shuffle ... ;
+M: #shuffle unbox-tuples*
+    [ flatten-values ] change-in-d
+    [ flatten-values ] change-out-d
+    [ unzip [ flatten-values ] bi@ zip ] change-mapping ;
 
-M: #terrible ... ;
+M: #terminate unbox-tuples*
+    [ flatten-values ] change-in-d ;
 
 ! These nodes never participate in unboxing
-M: #return drop ;
+M: #return unbox-tuples* ;
 
-M: #introduce drop ;
+M: #introduce unbox-tuples* ;
 
-: unbox-tuples ( nodes -- nodes )
+: unbox-tuples ( nodes -- nodes ) [ unbox-tuples* ] map-nodes ;
-    dup [ unbox-tuples* ] each-node ;