diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index df721f0c6c..5b06b37638 100644 --- a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor @@ -3,7 +3,8 @@ 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 ; +compiler.tree.def-use kernel accessors sequences math +sorting math.order binary-search ; \ unbox-tuples must-infer @@ -24,8 +25,11 @@ TUPLE: cons { car read-only } { cdr read-only } ; TUPLE: empty-tuple ; { + [ 1 2 cons boa [ car>> ] [ cdr>> ] bi ] [ 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>> ] + [ [ <=> ] sort ] + [ [ <=> ] with search ] } [ [ ] swap [ test-unboxing ] curry unit-test ] each diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor index 81933c37dc..71ff79d95b 100644 --- a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor @@ -72,6 +72,9 @@ M: #call unbox-tuples* [ drop ] } case ; +M: #declare unbox-tuples* + [ unzip [ flatten-values ] dip zip ] change-declaration ; + M: #copy unbox-tuples* [ flatten-values ] change-in-d [ flatten-values ] change-out-d ; @@ -92,9 +95,37 @@ M: #shuffle unbox-tuples* M: #terminate unbox-tuples* [ flatten-values ] change-in-d ; -! These nodes never participate in unboxing -M: #return unbox-tuples* ; +M: #phi unbox-tuples* + [ flip [ flatten-values ] map flip ] change-phi-in-d + [ flip [ flatten-values ] map flip ] change-phi-in-r + [ flatten-values ] change-out-d + [ flatten-values ] change-out-r ; -M: #introduce unbox-tuples* ; +M: #recursive unbox-tuples* + [ flatten-values ] change-in-d ; + +M: #enter-recursive unbox-tuples* + [ flatten-values ] change-in-d + [ flatten-values ] change-out-d ; + +M: #call-recursive unbox-tuples* + [ flatten-values ] change-in-d + [ flatten-values ] change-out-d ; + +M: #return-recursive unbox-tuples* + [ flatten-values ] change-in-d + [ flatten-values ] change-out-d ; + +! These nodes never participate in unboxing +: assert-not-unboxed ( values -- ) + dup array? + [ [ unboxed-allocation ] contains? ] [ unboxed-allocation ] if + [ "Unboxing wrong value" throw ] when ; + +M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ; + +M: #return unbox-tuples* dup in-d>> assert-not-unboxed ; + +M: #introduce unbox-tuples* dup value>> assert-not-unboxed ; : unbox-tuples ( nodes -- nodes ) [ unbox-tuples* ] map-nodes ;