steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

compiler.tree.propagation: don't constant-fold boa constructors of identity-tuple subclasses

release
Slava Pestov 2010-03-26 22:44:56 -04:00
parent 560c119cd2
commit e6a15c0b33
2 changed files with 15 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -467,6 +467,12 @@ TUPLE: fold-boa-test-tuple { x read-only } { y read-only } { z read-only } ;
[ [ 1 2 3 fold-boa-test-tuple boa ] final-literals ] [ [ 1 2 3 fold-boa-test-tuple boa ] final-literals ]
unit-test unit-test
TUPLE: don't-fold-boa-test-tuple < identity-tuple ;
[ V{ f } ]
[ [ don't-fold-boa-test-tuple boa ] final-literals ]
unit-test
TUPLE: immutable-prop-test-tuple { x sequence read-only } ; TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
[ V{ T{ immutable-prop-test-tuple f "hey" } } ] [ [ V{ T{ immutable-prop-test-tuple f "hey" } } ] [

17
basis/compiler/tree/propagation/slots/slots.factor
View File

@ -34,17 +34,18 @@ IN: compiler.tree.propagation.slots
[ read-only>> [ value-info ] [ drop f ] if ] 2map [ read-only>> [ value-info ] [ drop f ] if ] 2map
f prefix ; f prefix ;
: (propagate-tuple-constructor) ( values class -- info ) : fold-<tuple-boa>? ( values class -- ? )
[ read-only-slots ] keep [ rest-slice [ dup [ literal?>> ] when ] all? ]
over rest-slice [ dup [ literal?>> ] when ] all? [ [ identity-tuple class<= not ]
[ rest-slice ] dip fold-<tuple-boa> bi* and ;
] [
<tuple-info> : (propagate-<tuple-boa>) ( values class -- info )
] if ; [ read-only-slots ] keep 2dup fold-<tuple-boa>?
[ [ rest-slice ] dip fold-<tuple-boa> ] [ <tuple-info> ] if ;
: propagate-<tuple-boa> ( #call -- infos ) : propagate-<tuple-boa> ( #call -- infos )
in-d>> unclip-last in-d>> unclip-last
value-info literal>> first (propagate-tuple-constructor) 1array ; value-info literal>> first (propagate-<tuple-boa>) 1array ;
: read-only-slot? ( n class -- ? ) : read-only-slot? ( n class -- ? )
all-slots [ offset>> = ] with find nip all-slots [ offset>> = ] with find nip