1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel kernel.private math math.private words
4 sequences parser namespaces assocs quotations arrays
5 generic generic.math hashtables effects ;
6 IN: optimizer.math.partial
10 ! This code will be overhauled and generalized when
11 ! multi-methods go into the core.
12 PREDICATE: math-partial < word
13 "derived-from" word-prop >boolean ;
15 : fixnum-integer-op ( a b fix-word big-word -- c )
19 >r drop >r fixnum>bignum r> r> execute
22 : integer-fixnum-op ( a b fix-word big-word -- c )
26 drop fixnum>bignum r> execute
29 : integer-integer-op ( a b fix-word big-word -- c )
33 >r drop over tag 0 eq? [
34 >r fixnum>bignum r> r> execute
41 : integer-op-combinator ( triple -- word )
43 [ second word-name % "-" % ]
44 [ third word-name % "-op" % ]
46 ] "" make in get lookup ;
48 : integer-op-word ( triple fix-word big-word -- word )
51 word-name "fast" tail? >r
52 [ "-" % ] [ word-name % ] interleave
54 ] "" make in get create ;
56 : integer-op-quot ( word fix-word big-word -- quot )
57 rot integer-op-combinator 1quotation 2curry ;
59 : define-integer-op-word ( word fix-word big-word -- )
61 [ integer-op-word ] [ integer-op-quot ] 3bi
62 (( x y -- z )) define-declared
65 [ integer-op-word ] [ 2drop ] 3bi
66 "derived-from" set-word-prop
69 : define-integer-op-words ( words fix-word big-word -- )
70 [ define-integer-op-word ] 2curry each ;
72 : integer-op-triples ( word -- triples )
77 } swap [ prefix ] curry map ;
79 : define-integer-ops ( word fix-word big-word -- )
80 >r >r integer-op-triples r> r>
81 [ define-integer-op-words ]
82 [ [ 2drop ] [ [ integer-op-word ] 2curry map ] 3bi zip % ]
85 : define-math-ops ( op -- )
86 { fixnum bignum float }
87 [ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc
89 [ word-def peek ] assoc-map % ;
97 \ shift define-math-ops
101 \ bitand define-math-ops
102 \ bitor define-math-ops
103 \ bitxor define-math-ops
109 \ number= define-math-ops
111 \ + \ fixnum+ \ bignum+ define-integer-ops
112 \ - \ fixnum- \ bignum- define-integer-ops
113 \ * \ fixnum* \ bignum* define-integer-ops
114 \ shift \ fixnum-shift \ bignum-shift define-integer-ops
115 \ mod \ fixnum-mod \ bignum-mod define-integer-ops
116 \ /i \ fixnum/i \ bignum/i define-integer-ops
118 \ bitand \ fixnum-bitand \ bignum-bitand define-integer-ops
119 \ bitor \ fixnum-bitor \ bignum-bitor define-integer-ops
120 \ bitxor \ fixnum-bitxor \ bignum-bitxor define-integer-ops
122 \ < \ fixnum< \ bignum< define-integer-ops
123 \ <= \ fixnum<= \ bignum<= define-integer-ops
124 \ > \ fixnum> \ bignum> define-integer-ops
125 \ >= \ fixnum>= \ bignum>= define-integer-ops
126 \ number= \ eq? \ bignum= define-integer-ops
127 ] { } make >hashtable math-ops set-global
129 SYMBOL: fast-math-ops
132 { { + fixnum fixnum } fixnum+fast } ,
133 { { - fixnum fixnum } fixnum-fast } ,
134 { { * fixnum fixnum } fixnum*fast } ,
135 { { shift fixnum fixnum } fixnum-shift-fast } ,
137 \ + \ fixnum+fast \ bignum+ define-integer-ops
138 \ - \ fixnum-fast \ bignum- define-integer-ops
139 \ * \ fixnum*fast \ bignum* define-integer-ops
140 \ shift \ fixnum-shift-fast \ bignum-shift define-integer-ops
141 ] { } make >hashtable fast-math-ops set-global
145 : math-op ( word left right -- word' ? )
146 3array math-ops get at* ;
148 : math-method* ( word left right -- quot )
150 [ >r 3drop r> 1quotation ] [ drop math-method ] if ;
152 : math-both-known? ( word left right -- ? )
155 [ drop math-class-max swap specific-method >boolean ] if ;
157 : (derived-ops) ( word assoc -- words )
158 swap [ rot first eq? nip ] curry assoc-filter values ;
160 : derived-ops ( word -- words )
162 [ math-ops get (derived-ops) ]
165 : fast-derived-ops ( word -- words )
166 fast-math-ops get (derived-ops) ;
168 : all-derived-ops ( word -- words )
169 [ derived-ops ] [ fast-derived-ops ] bi append ;
171 : each-derived-op ( word quot -- )
172 >r derived-ops r> each ; inline