diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 7f5b9f6fcd..b154845c07 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -31,7 +31,6 @@ class interval literal literal? -length slots ; CONSTANT: null-info T{ value-info f null empty-interval } @@ -74,13 +73,20 @@ UNION: fixed-length array byte-array string ; ] unless ] unless ; +: length-slots ( length class -- slots ) + "slots" word-prop length 1 - f + swap prefix ; + : init-literal-info ( info -- info ) empty-interval >>interval dup literal>> literal-class >>class dup literal>> { { [ dup real? ] [ [a,a] >>interval ] } { [ dup tuple? ] [ tuple-slot-infos >>slots ] } - { [ dup fixed-length? ] [ length >>length ] } + { [ dup fixed-length? ] [ + [ length ] [ class ] bi + length-slots >>slots + ] } [ drop ] } cond ; inline @@ -158,11 +164,11 @@ UNION: fixed-length array byte-array string ; t >>literal? init-value-info ; foldable -: ( value -- info ) +: ( length class -- info ) - object >>class - swap value-info >>length - init-value-info ; foldable + over >>class + [ length-slots ] dip swap >>slots + init-value-info ; : ( slots class -- info ) @@ -185,13 +191,6 @@ DEFER: value-info-intersect DEFER: (value-info-intersect) -: intersect-lengths ( info1 info2 -- length ) - [ length>> ] bi@ { - { [ dup not ] [ drop ] } - { [ over not ] [ nip ] } - [ value-info-intersect ] - } cond ; - : intersect-slot ( info1 info2 -- info ) { { [ dup not ] [ nip ] } @@ -215,7 +214,6 @@ DEFER: (value-info-intersect) [ [ class>> ] bi@ class-and >>class ] [ [ interval>> ] bi@ interval-intersect >>interval ] [ intersect-literals [ >>literal ] [ >>literal? ] bi* ] - [ intersect-lengths >>length ] [ intersect-slots >>slots ] } 2cleave init-value-info ; @@ -236,13 +234,6 @@ DEFER: value-info-union DEFER: (value-info-union) -: union-lengths ( info1 info2 -- length ) - [ length>> ] bi@ { - { [ dup not ] [ nip ] } - { [ over not ] [ drop ] } - [ value-info-union ] - } cond ; - : union-slot ( info1 info2 -- info ) { { [ dup not ] [ nip ] } @@ -261,7 +252,6 @@ DEFER: (value-info-union) [ [ class>> ] bi@ class-or >>class ] [ [ interval>> ] bi@ interval-union >>interval ] [ union-literals [ >>literal ] [ >>literal? ] bi* ] - [ union-lengths >>length ] [ union-slots >>slots ] } 2cleave init-value-info ; @@ -293,7 +283,6 @@ DEFER: (value-info-union) { [ 2dup [ class>> ] bi@ class<= not ] [ f ] } { [ 2dup [ interval>> ] bi@ interval-subset? not ] [ f ] } { [ 2dup literals<= not ] [ f ] } - { [ 2dup [ length>> ] bi@ value-info<= not ] [ f ] } { [ 2dup [ slots>> ] bi@ [ value-info<= ] 2all? not ] [ f ] } [ t ] } cond 2nip diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor index eb4158e756..d4ab697e21 100644 --- a/basis/compiler/tree/propagation/recursive/recursive.factor +++ b/basis/compiler/tree/propagation/recursive/recursive.factor @@ -45,8 +45,7 @@ IN: compiler.tree.propagation.recursive [ clone ] dip [ [ drop ] [ [ [ interval>> ] bi@ ] [ drop class>> ] 2bi generalize-counter-interval ] 2bi >>interval ] [ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ] - [ [ drop ] [ [ length>> ] bi@ generalize-counter ] 2bi >>length ] - tri + bi ] if ] if ; diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 18d31985d6..6429928294 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -9,8 +9,6 @@ IN: compiler.tree.propagation.slots ! Propagation of immutable slots and array lengths -UNION: fixed-length-sequence array byte-array string ; - : sequence-constructor? ( word -- ? ) { (byte-array) } member-eq? ; @@ -23,9 +21,9 @@ UNION: fixed-length-sequence array byte-array string ; } at ; : propagate-sequence-constructor ( #call word -- infos ) - [ in-d>> first ] - [ constructor-output-class ] - bi* value-info-intersect 1array ; + [ in-d>> first value-info ] + [ constructor-output-class ] bi* + 1array ; : fold- ( values class -- info ) [ [ literal>> ] map ] dip prefix >tuple @@ -72,7 +70,6 @@ UNION: fixed-length-sequence array byte-array string ; : value-info-slot ( slot info -- info' ) { { [ over 0 = ] [ 2drop fixnum ] } - { [ 2dup length-accessor? ] [ nip length>> ] } { [ dup literal?>> ] [ literal>> literal-info-slot ] } [ [ 1 - ] [ slots>> ] bi* ?nth ] } cond [ object-info ] unless* ;