1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel arrays accessors sequences sequences.private words
4 fry namespaces math math.order memoize classes.builtin
5 classes.tuple.private slots.private combinators layouts
6 byte-arrays alien.accessors
10 compiler.tree.normalization
11 compiler.tree.propagation
12 compiler.tree.propagation.info
15 compiler.tree.dead-code
16 compiler.tree.combinators ;
17 IN: compiler.tree.finalization
19 ! This pass runs after propagation, so that it can expand
20 ! built-in type predicates and memory allocation; these cannot
21 ! be expanded before propagation since we need to see 'fixnum?'
22 ! instead of 'tag 0 eq?' and so on, for semantic reasoning.
23 ! We also delete empty stack shuffles and copies to facilitate
24 ! tail call optimization in the code generator. After this pass
25 ! runs, stack flow information is no longer accurate, since we
26 ! punt in 'splice-quot' and don't update everything that we
27 ! should; this simplifies the code, improves performance, and we
28 ! don't need the stack flow information after this pass anyway.
30 GENERIC: finalize* ( node -- nodes )
32 M: #copy finalize* drop f ;
36 [ in>> ] [ out>> ] bi sequence=
39 : splice-quot ( quot -- nodes )
50 : builtin-predicate? ( #call -- ? )
51 word>> "predicating" word-prop builtin-class? ;
53 MEMO: builtin-predicate-expansion ( word -- nodes )
56 : expand-builtin-predicate ( #call -- nodes )
57 word>> builtin-predicate-expansion ;
59 : first-literal ( #call -- obj ) node-input-infos first literal>> ;
61 : last-literal ( #call -- obj ) node-input-infos peek literal>> ;
63 : expand-tuple-boa? ( #call -- ? )
64 dup word>> \ <tuple-boa> eq? [
65 last-literal tuple-layout?
68 MEMO: (tuple-boa-expansion) ( n -- quot )
70 [ 2 + ] map <reversed>
71 [ '[ [ , set-slot ] keep ] % ] each
74 : tuple-boa-expansion ( layout -- quot )
75 #! No memoization here since otherwise we'd hang on to
76 #! tuple layout objects.
77 size>> (tuple-boa-expansion) \ (tuple) prefix splice-quot ;
79 : expand-tuple-boa ( #call -- node )
80 last-literal tuple-boa-expansion ;
82 MEMO: <array>-expansion ( n -- quot )
85 [ \ 2dup , , [ swap set-array-nth ] % ] each
87 ] [ ] make splice-quot ;
89 : expand-<array>? ( #call -- ? )
90 dup word>> \ <array> eq? [
91 first-literal dup integer?
92 [ 0 32 between? ] [ drop f ] if
95 : expand-<array> ( #call -- node )
96 first-literal <array>-expansion ;
98 : bytes>cells ( m -- n ) cell align cell /i ;
100 MEMO: <byte-array>-expansion ( n -- quot )
103 bytes>cells [ cell * ] map
104 [ [ 0 over ] % , [ set-alien-unsigned-cell ] % ] each
105 ] [ ] make splice-quot ;
107 : expand-<byte-array>? ( #call -- ? )
108 dup word>> \ <byte-array> eq? [
109 first-literal dup integer?
110 [ 0 128 between? ] [ drop f ] if
113 : expand-<byte-array> ( #call -- nodes )
114 first-literal <byte-array>-expansion ;
118 { [ dup builtin-predicate? ] [ expand-builtin-predicate ] }
119 { [ dup expand-tuple-boa? ] [ expand-tuple-boa ] }
120 { [ dup expand-<array>? ] [ expand-<array> ] }
121 { [ dup expand-<byte-array>? ] [ expand-<byte-array> ] }
127 : finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;