1 ;;;; stuff to handle simple cases for generic arithmetic
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 (define-assembly-routine (generic-+
16 (:return-style
:full-call
)
20 ((:arg x
(descriptor-reg any-reg
) a0-offset
)
21 (:arg y
(descriptor-reg any-reg
) a1-offset
)
23 (:res res
(descriptor-reg any-reg
) a0-offset
)
25 (:temp temp non-descriptor-reg nl0-offset
)
26 (:temp temp2 non-descriptor-reg nl1-offset
)
27 (:temp temp3 non-descriptor-reg nl2-offset
)
28 (:temp lip interior-reg lip-offset
)
29 (:temp lra descriptor-reg lra-offset
)
30 (:temp nargs any-reg nargs-offset
)
31 (:temp ocfp any-reg ocfp-offset
))
33 (inst bne temp DO-STATIC-FUN
)
35 (inst bne temp DO-STATIC-FUN
)
38 ; Check whether we need a bignum.
39 (inst sra res
31 temp
)
43 (inst sra res
2 temp3
)
45 ; from move-from-signed
47 (inst sra temp3
31 temp
)
48 (inst cmoveq temp
1 temp2
)
50 (inst cmoveq temp
1 temp2
)
51 (inst sll temp2 n-widetag-bits temp2
)
52 (inst bis temp2 bignum-widetag temp2
)
54 (pseudo-atomic (:extra
(pad-data-block (+ bignum-digits-offset
3)))
55 (inst bis alloc-tn other-pointer-lowtag res
)
56 (storew temp2 res
0 other-pointer-lowtag
)
57 (storew temp3 res bignum-digits-offset other-pointer-lowtag
)
58 (inst srl temp3
32 temp
)
59 (storew temp res
(1+ bignum-digits-offset
) other-pointer-lowtag
))
61 (lisp-return lra lip
:offset
2)
64 (inst ldl lip
(static-fun-offset 'two-arg-
+) null-tn
)
65 (inst li
(fixnumize 2) nargs
)
66 (inst move cfp-tn ocfp
)
67 (inst move csp-tn cfp-tn
)
68 (inst jmp zero-tn lip
))
71 (define-assembly-routine (generic--
73 (:return-style
:full-call
)
77 ((:arg x
(descriptor-reg any-reg
) a0-offset
)
78 (:arg y
(descriptor-reg any-reg
) a1-offset
)
80 (:res res
(descriptor-reg any-reg
) a0-offset
)
82 (:temp temp non-descriptor-reg nl0-offset
)
83 (:temp temp2 non-descriptor-reg nl1-offset
)
84 (:temp temp3 non-descriptor-reg nl2-offset
)
85 (:temp lip interior-reg lip-offset
)
86 (:temp lra descriptor-reg lra-offset
)
87 (:temp nargs any-reg nargs-offset
)
88 (:temp ocfp any-reg ocfp-offset
))
90 (inst bne temp DO-STATIC-FUN
)
92 (inst bne temp DO-STATIC-FUN
)
95 ; Check whether we need a bignum.
96 (inst sra res
31 temp
)
100 (inst sra res
2 temp3
)
102 ; from move-from-signed
104 (inst sra temp3
31 temp
)
105 (inst cmoveq temp
1 temp2
)
107 (inst cmoveq temp
1 temp2
)
108 (inst sll temp2 n-widetag-bits temp2
)
109 (inst bis temp2 bignum-widetag temp2
)
111 (pseudo-atomic (:extra
(pad-data-block (+ bignum-digits-offset
3)))
112 (inst bis alloc-tn other-pointer-lowtag res
)
113 (storew temp2 res
0 other-pointer-lowtag
)
114 (storew temp3 res bignum-digits-offset other-pointer-lowtag
)
115 (inst srl temp3
32 temp
)
116 (storew temp res
(1+ bignum-digits-offset
) other-pointer-lowtag
))
118 (lisp-return lra lip
:offset
2)
121 (inst ldl lip
(static-fun-offset 'two-arg--
) null-tn
)
122 (inst li
(fixnumize 2) nargs
)
123 (inst move cfp-tn ocfp
)
124 (inst move csp-tn cfp-tn
)
125 (inst jmp zero-tn lip
))
128 (define-assembly-routine (generic-*
130 (:return-style
:full-call
)
134 ((:arg x
(descriptor-reg any-reg
) a0-offset
)
135 (:arg y
(descriptor-reg any-reg
) a1-offset
)
137 (:res res
(descriptor-reg any-reg
) a0-offset
)
139 (:temp temp non-descriptor-reg nl0-offset
)
140 (:temp lo non-descriptor-reg nl1-offset
)
141 (:temp hi non-descriptor-reg nl2-offset
)
142 (:temp temp2 non-descriptor-reg nl3-offset
)
143 (:temp lip interior-reg lip-offset
)
144 (:temp lra descriptor-reg lra-offset
)
145 (:temp nargs any-reg nargs-offset
)
146 (:temp ocfp any-reg ocfp-offset
))
147 ;; If either arg is not a fixnum, call the static function.
149 (inst bne temp DO-STATIC-FUN
)
151 (inst bne temp DO-STATIC-FUN
)
153 ;; Remove the tag from one arg so that the result will have the
154 ;; correct fixnum tag.
156 (inst mulq temp y lo
)
159 (inst sra res
32 res
)
160 ;; Check to see if the result will fit in a fixnum. (I.e. the high
161 ;; word is just 32 copies of the sign bit of the low word).
162 (inst sra res
31 temp
)
163 (inst xor hi temp temp
)
165 ;; Shift the double word hi:res down two bits into hi:low to get rid
166 ;; of the fixnum tag.
170 ;; Do we need one word or two? Assume two.
171 (inst li
(logior (ash 2 n-widetag-bits
) bignum-widetag
) temp2
)
172 (inst sra lo
31 temp
)
173 (inst xor temp hi temp
)
174 (inst bne temp two-words
)
176 ;; Only need one word, fix the header.
177 (inst li
(logior (ash 1 n-widetag-bits
) bignum-widetag
) temp2
)
178 ;; Allocate one word.
179 (pseudo-atomic (:extra
(pad-data-block (1+ bignum-digits-offset
)))
180 (inst bis alloc-tn other-pointer-lowtag res
)
181 (storew temp2 res
0 other-pointer-lowtag
))
183 (storew lo res bignum-digits-offset other-pointer-lowtag
)
185 (lisp-return lra lip
:offset
2)
188 ;; Allocate two words.
189 (pseudo-atomic (:extra
(pad-data-block (+ 2 bignum-digits-offset
)))
190 (inst bis alloc-tn other-pointer-lowtag res
)
191 (storew temp2 res
0 other-pointer-lowtag
))
193 (storew lo res bignum-digits-offset other-pointer-lowtag
)
194 (storew hi res
(1+ bignum-digits-offset
) other-pointer-lowtag
)
196 (lisp-return lra lip
:offset
2)
199 (inst ldl lip
(static-fun-offset 'two-arg-
*) null-tn
)
200 (inst li
(fixnumize 2) nargs
)
201 (inst move cfp-tn ocfp
)
202 (inst move csp-tn cfp-tn
)
203 (inst jmp zero-tn lip
)
210 (define-assembly-routine (signed-truncate
211 (:note
"(signed-byte 64) truncate")
214 (:translate truncate
)
215 (:arg-types signed-num signed-num
)
216 (:result-types signed-num signed-num
))
218 ((:arg dividend signed-reg nl0-offset
)
219 (:arg divisor signed-reg nl1-offset
)
221 (:res quo signed-reg nl2-offset
)
222 (:res rem signed-reg nl3-offset
)
224 (:temp quo-sign signed-reg nl5-offset
)
225 (:temp rem-sign signed-reg nargs-offset
)
226 (:temp temp1 non-descriptor-reg nl4-offset
))
228 (let ((error (generate-error-code nil division-by-zero-error
230 (inst beq divisor error
))
232 (inst xor dividend divisor quo-sign
)
233 (inst move dividend rem-sign
)
234 (let ((label (gen-label)))
235 (inst bge dividend label
)
236 (inst subq zero-tn dividend dividend
)
238 (let ((label (gen-label)))
239 (inst bge divisor label
)
240 (inst subq zero-tn divisor divisor
)
242 (inst move zero-tn rem
)
243 (inst move zero-tn quo
)
246 (inst srl dividend
63 temp1
)
248 (inst bis temp1 rem rem
)
249 (inst cmple divisor rem temp1
)
251 (inst bis temp1 quo quo
)
252 (inst sll dividend
1 dividend
)
253 (inst subq temp1
1 temp1
)
254 (inst zap divisor temp1 temp1
)
255 (inst subq rem temp1 rem
))
257 (let ((label (gen-label)))
258 ;; If the quo-sign is negative, we need to negate quo.
259 (inst bge quo-sign label
)
260 (inst subq zero-tn quo quo
)
262 (let ((label (gen-label)))
263 ;; If the rem-sign is negative, we need to negate rem.
264 (inst bge rem-sign label
)
265 (inst subq zero-tn rem rem
)
269 ;;;; comparison routines
272 ((define-cond-assem-rtn (name translate static-fn cmp not-p
)
273 `(define-assembly-routine (,name
275 (:return-style
:full-call
)
277 (:translate
,translate
)
279 ((:arg x
(descriptor-reg any-reg
) a0-offset
)
280 (:arg y
(descriptor-reg any-reg
) a1-offset
)
282 (:res res descriptor-reg a0-offset
)
284 (:temp temp non-descriptor-reg nl0-offset
)
285 (:temp lip interior-reg lip-offset
)
286 (:temp nargs any-reg nargs-offset
)
287 (:temp ocfp any-reg ocfp-offset
))
289 (inst bne temp DO-STATIC-FN
)
291 (inst beq temp DO-COMPARE
)
294 (inst ldl lip
(static-fun-offset ',static-fn
) null-tn
)
295 (inst li
(fixnumize 2) nargs
)
296 (inst move cfp-tn ocfp
)
297 (inst move csp-tn cfp-tn
)
298 (inst jmp zero-tn lip
)
302 (inst move null-tn res
)
303 (inst ,(if not-p
'bne
'beq
) temp done
)
307 (define-cond-assem-rtn generic-
< < two-arg-
< (inst cmplt x y temp
) nil
)
308 (define-cond-assem-rtn generic-
> > two-arg-
> (inst cmplt y x temp
) nil
))
311 (define-assembly-routine (generic-eql
313 (:return-style
:full-call
)
317 ((:arg x
(descriptor-reg any-reg
) a0-offset
)
318 (:arg y
(descriptor-reg any-reg
) a1-offset
)
320 (:res res descriptor-reg a0-offset
)
322 (:temp temp non-descriptor-reg nl0-offset
)
323 (:temp lip interior-reg lip-offset
)
324 (:temp lra descriptor-reg lra-offset
)
325 (:temp nargs any-reg nargs-offset
)
326 (:temp ocfp any-reg ocfp-offset
))
327 (inst cmpeq x y temp
)
328 (inst bne temp RETURN-T
)
330 (inst beq temp RETURN-NIL
)
332 (inst bne temp DO-STATIC-FN
)
335 (inst move null-tn res
)
336 (lisp-return lra lip
:offset
2)
339 (inst ldl lip
(static-fun-offset 'eql
) null-tn
)
340 (inst li
(fixnumize 2) nargs
)
341 (inst move cfp-tn ocfp
)
342 (inst move csp-tn cfp-tn
)
343 (inst jmp zero-tn lip
)
348 (define-assembly-routine (generic-=
350 (:return-style
:full-call
)
354 ((:arg x
(descriptor-reg any-reg
) a0-offset
)
355 (:arg y
(descriptor-reg any-reg
) a1-offset
)
357 (:res res descriptor-reg a0-offset
)
359 (:temp temp non-descriptor-reg nl0-offset
)
360 (:temp lip interior-reg lip-offset
)
361 (:temp lra descriptor-reg lra-offset
)
362 (:temp nargs any-reg nargs-offset
)
363 (:temp ocfp any-reg ocfp-offset
))
365 (inst bne temp DO-STATIC-FN
)
367 (inst bne temp DO-STATIC-FN
)
368 (inst cmpeq x y temp
)
369 (inst bne temp RETURN-T
)
371 (inst move null-tn res
)
372 (lisp-return lra lip
:offset
2)
375 (inst ldl lip
(static-fun-offset 'two-arg-
=) null-tn
)
376 (inst li
(fixnumize 2) nargs
)
377 (inst move cfp-tn ocfp
)
378 (inst move csp-tn cfp-tn
)
379 (inst jmp zero-tn lip
)
384 (define-assembly-routine (generic-/=
386 (:return-style
:full-call
)
390 ((:arg x
(descriptor-reg any-reg
) a0-offset
)
391 (:arg y
(descriptor-reg any-reg
) a1-offset
)
393 (:res res descriptor-reg a0-offset
)
395 (:temp temp non-descriptor-reg nl0-offset
)
396 (:temp lip interior-reg lip-offset
)
397 (:temp lra descriptor-reg lra-offset
)
398 (:temp nargs any-reg nargs-offset
)
399 (:temp ocfp any-reg ocfp-offset
))
401 (inst bne temp DO-STATIC-FN
)
403 (inst bne temp DO-STATIC-FN
)
404 (inst cmpeq x y temp
)
405 (inst bne temp RETURN-NIL
)
408 (lisp-return lra lip
:offset
2)
411 (inst ldl lip
(static-fun-offset 'two-arg-
/=) null-tn
)
412 (inst li
(fixnumize 2) nargs
)
413 (inst move cfp-tn ocfp
)
414 (inst move csp-tn cfp-tn
)
415 (inst jmp zero-tn lip
)
418 (inst move null-tn res
))