1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: fry assocs arrays byte-arrays strings accessors sequences
4 kernel slots classes.algebra classes.tuple classes.tuple.private
5 words math math.private combinators sequences.private namespaces
6 slots.private classes compiler.tree.propagation.info ;
7 IN: compiler.tree.propagation.slots
9 ! Propagation of immutable slots and array lengths
11 ! Revisit this code when delegation is removed and when complex
12 ! numbers become tuples.
14 UNION: fixed-length-sequence array byte-array string ;
16 : sequence-constructor? ( word -- ? )
17 { <array> <byte-array> (byte-array) <string> } memq? ;
19 : constructor-output-class ( word -- class )
22 { <byte-array> byte-array }
23 { (byte-array) byte-array }
27 : propagate-sequence-constructor ( #call word -- infos )
28 [ in-d>> first <sequence-info> ]
29 [ constructor-output-class <class-info> ]
30 bi* value-info-intersect 1array ;
32 : tuple-constructor? ( word -- ? )
33 { <tuple-boa> <complex> } memq? ;
35 : fold-<tuple-boa> ( values class -- info )
36 [ [ literal>> ] map ] dip prefix >tuple
39 : (propagate-tuple-constructor) ( values class -- info )
40 [ [ value-info ] map ] dip [ read-only-slots ] keep
41 over rest-slice [ dup [ literal?>> ] when ] all? [
42 [ rest-slice ] dip fold-<tuple-boa>
47 : propagate-<tuple-boa> ( #call -- info )
49 value-info literal>> first (propagate-tuple-constructor) ;
51 : propagate-<complex> ( #call -- info )
52 in-d>> [ value-info ] map complex <tuple-info> ;
54 : propagate-tuple-constructor ( #call word -- infos )
56 { \ <tuple-boa> [ propagate-<tuple-boa> ] }
57 { \ <complex> [ propagate-<complex> ] }
60 : read-only-slot? ( n class -- ? )
61 all-slots [ offset>> = ] with find nip
62 dup [ read-only>> ] when ;
64 : literal-info-slot ( slot object -- info/f )
65 2dup class read-only-slot?
66 [ swap slot <literal-info> ] [ 2drop f ] if ;
68 : length-accessor? ( slot info -- ? )
69 [ 1 = ] [ length>> ] bi* and ;
71 : value-info-slot ( slot info -- info' )
73 { [ over 0 = ] [ 2drop fixnum <class-info> ] }
74 { [ 2dup length-accessor? ] [ nip length>> ] }
75 { [ dup literal?>> ] [ literal>> literal-info-slot ] }
76 [ [ 1- ] [ slots>> ] bi* ?nth ]
77 } cond [ object-info ] unless* ;