1 ! Copyright (C) 2005, 2006 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: alien arrays assembler kernel kernel-internals math
4 math-internals namespaces sequences words ;
9 "in" operand tag-mask AND
10 "in" operand tag-bits SHL
12 { +input+ { { f "in" } } }
17 #! Intrinstic version of type primitive.
22 "x" operand "obj" operand MOV
24 "obj" operand tag-mask AND
25 ! Compare with object tag number (3).
26 "obj" operand object-tag CMP
27 ! Jump if the object doesn't store type info in its header
29 ! It doesn't store type info in its header
30 "obj" operand tag-bits SHL
32 "header" resolve-label
33 ! It does store type info in its header
34 ! Is the pointer itself equal to 3? Then its F_TYPE (9).
35 "x" operand object-tag CMP
37 ! The pointer is not equal to 3. Load the object header.
38 "obj" operand "x" operand object-tag neg [+] MOV
39 ! Mask off header tag, making a fixnum.
40 "obj" operand object-tag XOR
43 ! The pointer is equal to 3. Load F_TYPE (9).
44 "obj" operand f type tag-bits shift MOV
47 { +input+ { { f "obj" } } }
48 { +scratch+ { { f "x" } { f "y" } } }
49 { +output+ { "obj" } }
53 : %untag ( reg -- ) tag-mask bitnot AND ;
57 ! turn tagged fixnum slot # into an offset, multiple of 4
58 "n" operand fixnum>slot@
59 ! compute slot address
60 "obj" operand "n" operand ADD
62 "obj" operand dup [] MOV
64 { +input+ { { f "obj" } { f "n" } } }
65 { +output+ { "obj" } }
69 : generate-write-barrier ( -- )
70 #! Mark the card pointed to by vreg.
71 "obj" operand card-bits SHR
72 "obj" operand HEX: ffff ADD rel-absolute-cell rel-cards
73 "obj" operand [] card-mark OR ;
77 ! turn tagged fixnum slot # into an offset
78 "slot" operand fixnum>slot@
79 ! compute slot address
80 "slot" operand "obj" operand ADD
81 ! store new slot value
82 "slot" operand [] "val" operand MOV
83 generate-write-barrier
85 { +input+ { { f "val" } { f "obj" } { f "slot" } } }
86 { +clobber+ { "obj" "slot" } }
89 : char-reg cell 8 = RBX EBX ? ; inline
90 : char-reg-16 BX ; inline
96 "obj" operand "n" operand ADD
97 char-reg-16 "obj" operand string-offset [+] MOV
99 "obj" operand char-reg MOV
102 { +input+ { { f "n" } { f "obj" } } }
103 { +output+ { "obj" } }
104 { +clobber+ { "n" } }
109 "val" operand tag-bits SHR
111 "obj" operand "slot" operand ADD
112 char-reg "val" operand MOV
113 "obj" operand string-offset [+] char-reg-16 MOV
116 { +input+ { { f "val" } { f "slot" } { f "obj" } } }
117 { +clobber+ { "val" "slot" "obj" } }
121 : define-fixnum-op ( word op -- )
122 [ [ "x" operand "y" operand ] % , ] [ ] make H{
123 { +input+ { { f "x" } { f "y" } } }
130 { fixnum-bitand AND }
132 { fixnum-bitxor XOR }
134 first2 define-fixnum-op
139 "x" operand tag-mask XOR
141 { +input+ { { f "x" } } }
145 ! This has specific register requirements. Inputs are in
146 ! ECX and EAX, and the result is in EDX.
151 { +input+ { { 0 "x" } { 1 "y" } } }
152 { +scratch+ { { 2 "out" } } }
153 { +output+ { "out" } }
156 : %untag-fixnums ( seq -- )
157 [ tag-bits SAR ] unique-operands ;
159 : simple-overflow ( word -- )
161 "z" operand "x" operand MOV
162 "z" operand "y" operand pick execute
163 ! If the previous arithmetic operation overflowed, then we
164 ! turn the result into a bignum and leave it in EAX.
166 ! There was an overflow. Recompute the original operand.
167 { "y" "x" } %untag-fixnums
168 "x" operand "y" operand rot execute
169 "z" operand "x" operand %allot-bignum-signed-1
170 "end" resolve-label ; inline
172 : simple-overflow-template ( word insn -- )
173 [ simple-overflow ] curry H{
174 { +input+ { { f "x" } { f "y" } } }
175 { +scratch+ { { f "z" } } }
177 { +clobber+ { "x" "y" } }
180 \ fixnum+ \ ADD simple-overflow-template
181 \ fixnum- \ SUB simple-overflow-template
183 : %tag-overflow ( -- )
184 #! Tag a cell-size value, where the tagging might posibly
185 #! overflow BUT IT MUST NOT EXCEED cell-2 BITS
186 "y" operand "x" operand MOV ! Make a copy
187 "x" operand 1 tag-bits shift IMUL2 ! Tag it
188 "end" get JNO ! Overflow?
189 "x" operand "y" operand %allot-bignum-signed-1 ! Yes, box bignum
193 ! "overflow-1" define-label
194 ! "overflow-2" define-label
196 ! { "y" "x" } %untag-fixnums
198 ! "overflow-1" get JNO
199 ! "x" operand "r" operand %allot-bignum-signed-2
201 ! "overflow-1" resolve-label
203 ! "end" resolve-label
205 ! { +input+ { { 0 "x" } { 1 "y" } } }
206 ! { +output+ { "x" } }
207 ! { +scratch+ { { 2 "r" } } }
208 ! { +clobber+ { "y" } }
211 : generate-fixnum/mod
212 #! The same code is used for fixnum/i and fixnum/mod.
213 #! This has specific register
214 #! ECX and EAX, and the result is in EDX.
219 "end" resolve-label ;
221 \ fixnum/i [ generate-fixnum/mod ] H{
222 { +input+ { { 0 "x" } { 1 "y" } } }
223 { +scratch+ { { 2 "r" } } }
225 { +clobber+ { "x" "y" } }
228 \ fixnum/mod [ generate-fixnum/mod ] H{
229 { +input+ { { 0 "x" } { 1 "y" } } }
230 { +scratch+ { { 2 "r" } } }
231 { +output+ { "x" "r" } }
232 { +clobber+ { "x" "y" } }
235 : define-fixnum-jump ( word op -- )
236 [ "x" operand "y" operand CMP ] swap add
237 { { f "x" } { f "y" } } define-if-intrinsic ;
246 first2 define-fixnum-jump
250 "nonzero" define-label
252 "x" operand 0 CMP ! is it zero?
254 0 >bignum "x" get load-literal
256 "nonzero" resolve-label
257 "x" operand tag-bits SAR
258 "x" operand dup %allot-bignum-signed-1
261 { +input+ { { f "x" } } }
266 "nonzero" define-label
267 "positive" define-label
270 "y" operand "x" operand cell [+] MOV
271 ! if the length is 1, its just the sign and nothing else,
273 "y" operand 1 tag-bits shift CMP
277 "nonzero" resolve-label
279 "y" operand "x" operand 3 cells [+] MOV
281 "x" operand "x" operand 2 cells [+] MOV
282 ! is the sign negative?
286 "positive" resolve-label
290 { +input+ { { f "x" } } }
291 { +scratch+ { { f "y" } } }
292 { +clobber+ { "x" } }
299 "userenv" f rel-absolute-cell rel-dlsym
300 "n" operand fixnum>slot@
301 "n" operand "x" operand ADD ;
304 %userenv "n" operand dup [] MOV
306 { +input+ { { f "n" } } }
307 { +scratch+ { { f "x" } } }
312 %userenv "n" operand [] "val" operand MOV
314 { +input+ { { f "val" } { f "n" } } }
315 { +scratch+ { { f "x" } } }
316 { +clobber+ { "n" } }