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

compiler.tree.propagation: clean up

db4
Slava Pestov 2010-03-10 15:15:49 +13:00
parent 1bf7db20ed
commit 7744559a46
2 changed files with 10 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
basis/compiler/tree/propagation/info/info.factor
View File

@ -47,9 +47,7 @@ CONSTANT: object-info T{ value-info f object full-interval }
{ [ over interval-length 0 > ] [ 3drop f f ] } { [ over interval-length 0 > ] [ 3drop f f ] }
{ [ pick bignum class<= ] [ 2nip >bignum t ] } { [ pick bignum class<= ] [ 2nip >bignum t ] }
{ [ pick integer class<= ] [ 2nip >fixnum t ] } { [ pick integer class<= ] [ 2nip >fixnum t ] }
{ [ pick float class<= ] [ { [ pick float class<= ] [ 2nip dup zero? [ drop f f ] [ >float t ] if ] }
2nip dup zero? [ drop f f ] [ >float t ] if
] }
[ 3drop f f ] [ 3drop f f ]
} cond } cond
] if ; ] if ;
@ -73,9 +71,11 @@ UNION: fixed-length array byte-array string ;
] unless ] unless
] unless ; ] unless ;
: length-slots ( length class -- slots ) : (slots-with-length) ( length class -- slots )
"slots" word-prop length 1 - f <array> "slots" word-prop length 1 - f <array> swap prefix ;
swap prefix ;
: slots-with-length ( seq -- slots )
[ length <literal-info> ] [ class ] bi (slots-with-length) ;
: init-literal-info ( info -- info ) : init-literal-info ( info -- info )
empty-interval >>interval empty-interval >>interval
@ -83,10 +83,7 @@ UNION: fixed-length array byte-array string ;
dup literal>> { dup literal>> {
{ [ dup real? ] [ [a,a] >>interval ] } { [ dup real? ] [ [a,a] >>interval ] }
{ [ dup tuple? ] [ tuple-slot-infos >>slots ] } { [ dup tuple? ] [ tuple-slot-infos >>slots ] }
{ [ dup fixed-length? ] [ { [ dup fixed-length? ] [ slots-with-length >>slots ] }
[ length <literal-info> ] [ class ] bi
length-slots >>slots
] }
[ drop ] [ drop ]
} cond ; inline } cond ; inline
@ -164,10 +161,10 @@ UNION: fixed-length array byte-array string ;
t >>literal? t >>literal?
init-value-info ; foldable init-value-info ; foldable
: <sequence-info'> ( length class -- info ) : <sequence-info> ( length class -- info )
<value-info> <value-info>
over >>class over >>class
[ length-slots ] dip swap >>slots [ (slots-with-length) ] dip swap >>slots
init-value-info ; init-value-info ;
: <tuple-info> ( slots class -- info ) : <tuple-info> ( slots class -- info )

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

@ -23,7 +23,7 @@ IN: compiler.tree.propagation.slots
: propagate-sequence-constructor ( #call word -- infos ) : propagate-sequence-constructor ( #call word -- infos )
[ in-d>> first value-info ] [ in-d>> first value-info ]
[ constructor-output-class ] bi* [ constructor-output-class ] bi*
<sequence-info'> 1array ; <sequence-info> 1array ;
: fold-<tuple-boa> ( values class -- info ) : fold-<tuple-boa> ( values class -- info )
[ [ literal>> ] map ] dip prefix >tuple [ [ literal>> ] map ] dip prefix >tuple