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 ;;;; Addition and subtraction.
16 (define-assembly-routine (generic-+
18 (:return-style :full-call)
22 ((:arg x (descriptor-reg any-reg) a0-offset)
23 (:arg y (descriptor-reg any-reg) a1-offset)
25 (:res res (descriptor-reg any-reg) a0-offset)
27 (:temp temp non-descriptor-reg nl0-offset)
28 (:temp temp2 non-descriptor-reg nl1-offset)
29 (:temp lra descriptor-reg lra-offset)
30 (:temp nargs any-reg nargs-offset)
31 (:temp ocfp any-reg ocfp-offset))
32 (inst andcc zero-tn x fixnum-tag-mask)
33 (inst b :ne DO-STATIC-FUN)
34 (inst andcc zero-tn y fixnum-tag-mask)
35 (inst b :ne DO-STATIC-FUN)
41 (inst sra temp x fixnum-tag-bits)
42 (inst sra temp2 y fixnum-tag-bits)
44 (with-fixed-allocation (res temp bignum-widetag (1+ bignum-digits-offset))
45 (storew temp2 res bignum-digits-offset other-pointer-lowtag))
46 (lisp-return lra :offset 2)
49 (inst ld code-tn null-tn (static-fun-offset 'two-arg-+))
50 (inst li nargs (fixnumize 2))
51 (inst move ocfp cfp-tn)
53 (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
54 (inst move cfp-tn csp-tn)
60 (define-assembly-routine (generic--
62 (:return-style :full-call)
66 ((:arg x (descriptor-reg any-reg) a0-offset)
67 (:arg y (descriptor-reg any-reg) a1-offset)
69 (:res res (descriptor-reg any-reg) a0-offset)
71 (:temp temp non-descriptor-reg nl0-offset)
72 (:temp temp2 non-descriptor-reg nl1-offset)
73 (:temp lra descriptor-reg lra-offset)
74 (:temp nargs any-reg nargs-offset)
75 (:temp ocfp any-reg ocfp-offset))
76 (inst andcc zero-tn x fixnum-tag-mask)
77 (inst b :ne DO-STATIC-FUN)
78 (inst andcc zero-tn y fixnum-tag-mask)
79 (inst b :ne DO-STATIC-FUN)
85 (inst sra temp x fixnum-tag-bits)
86 (inst sra temp2 y fixnum-tag-bits)
87 (inst sub temp2 temp temp2)
88 (with-fixed-allocation (res temp bignum-widetag (1+ bignum-digits-offset))
89 (storew temp2 res bignum-digits-offset other-pointer-lowtag))
90 (lisp-return lra :offset 2)
93 (inst ld code-tn null-tn (static-fun-offset 'two-arg--))
94 (inst li nargs (fixnumize 2))
95 (inst move ocfp cfp-tn)
97 (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
98 (inst move cfp-tn csp-tn)
108 (define-assembly-routine (generic-*
110 (:return-style :full-call)
114 ((:arg x (descriptor-reg any-reg) a0-offset)
115 (:arg y (descriptor-reg any-reg) a1-offset)
117 (:res res (descriptor-reg any-reg) a0-offset)
119 (:temp temp non-descriptor-reg nl0-offset)
120 (:temp lo non-descriptor-reg nl1-offset)
121 (:temp hi non-descriptor-reg nl2-offset)
122 (:temp lra descriptor-reg lra-offset)
123 (:temp nargs any-reg nargs-offset)
124 (:temp ocfp any-reg ocfp-offset))
125 ;; If either arg is not a fixnum, call the static function.
126 (inst andcc zero-tn x fixnum-tag-mask)
127 (inst b :ne DO-STATIC-FUN)
128 (inst andcc zero-tn y fixnum-tag-mask)
129 (inst b :ne DO-STATIC-FUN)
132 ;; Remove the tag from one arg so that the result will have the correct
134 (inst sra temp x fixnum-tag-bits)
135 ;; Compute the produce temp * y and return the double-word product
138 ;; FIXME: Note that the below shebang read-time conditionals aren't
139 ;; actually shebang. This is because the assembly files are also
140 ;; built in warm-init, when #! is not a defined read-macro. This
141 ;; problem will actually go away when we rewrite these low-level
142 ;; bits and pieces to use the backend-subfeatures machinery, as we
143 ;; will then conditionalize at code-emission time or assembly time
144 ;; for the VOP and the assembly routine respectively. - CSR,
147 ;; Sign extend y to a full 64-bits. temp was already
148 ;; sign-extended by the sra instruction above.
151 (inst mulx hi temp y)
154 #+(and (not :sparc-64) (or :sparc-v8 :sparc-v9))
156 (inst smul lo temp y)
158 #+(and (not :sparc-64) (not (or :sparc-v8 :sparc-v9)))
159 (let ((MULTIPLIER-POSITIVE (gen-label)))
161 (inst andcc hi zero-tn)
166 (inst mulscc hi zero-tn)
168 (inst b :ge MULTIPLIER-POSITIVE)
171 (emit-label MULTIPLIER-POSITIVE)
174 ;; Check to see if the result will fit in a fixnum. (I.e. the high word
175 ;; is just 32 copies of the sign bit of the low word).
176 (inst sra temp lo 31)
178 (inst b :eq LOW-FITS-IN-FIXNUM)
179 ;; Shift the double word hi:lo down two bits to get rid of the fixnum tag.
180 (inst sll temp hi 30)
181 (inst srl lo fixnum-tag-bits)
183 (inst sra hi fixnum-tag-bits)
184 ;; Allocate a BIGNUM for the result.
186 (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset)))
187 (let ((one-word (gen-label)))
188 (inst or res alloc-tn other-pointer-lowtag)
189 ;; We start out assuming that we need one word. Is that correct?
190 (inst sra temp lo 31)
192 (inst b :eq one-word)
193 (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
194 ;; Nope, we need two, so allocate the addition space.
195 (inst add alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset))
196 (pad-data-block (1+ bignum-digits-offset))))
197 (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
198 (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
199 (emit-label one-word)
200 (storew temp res 0 other-pointer-lowtag)
201 (storew lo res bignum-digits-offset other-pointer-lowtag)))
202 ;; Always allocate 2 words for the bignum result, even if we only
203 ;; need one. The copying GC will take care of the extra word if it
205 (with-fixed-allocation
206 (res temp bignum-widetag (+ 2 bignum-digits-offset))
207 (let ((one-word (gen-label)))
208 (inst or res alloc-tn other-pointer-lowtag)
209 ;; We start out assuming that we need one word. Is that correct?
210 (inst sra temp lo 31)
212 (inst b :eq one-word)
213 (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
214 ;; Need 2 words. Set the header appropriately, and save the
215 ;; high and low parts.
216 (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
217 (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
218 (emit-label one-word)
219 (storew temp res 0 other-pointer-lowtag)
220 (storew lo res bignum-digits-offset other-pointer-lowtag)))
222 (lisp-return lra :offset 2)
225 (inst ld code-tn null-tn (static-fun-offset 'two-arg-*))
226 (inst li nargs (fixnumize 2))
227 (inst move ocfp cfp-tn)
229 (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
230 (inst move cfp-tn csp-tn)
236 ((frob (name note cost type sc)
237 `(define-assembly-routine (,name
242 (:arg-types ,type ,type)
243 (:result-types ,type))
244 ((:arg x ,sc nl0-offset)
245 (:arg y ,sc nl1-offset)
246 (:res res ,sc nl0-offset)
247 (:temp temp ,sc nl2-offset))
248 ,@(when (eq type 'tagged-num)
251 ;; Sign extend, then multiply
256 #+(and (not :sparc-64) (or :sparc-v8 :sparc-v9))
258 #+(and (not :sparc-64) (not (or :sparc-v8 :sparc-v9)))
261 (inst andcc temp zero-tn)
265 (inst mulscc temp y))
266 (inst mulscc temp zero-tn)
268 (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg)
269 (frob signed-* "unsigned *" 41 signed-num signed-reg)
270 (frob fixnum-* "fixnum *" 30 tagged-num any-reg))
277 (defun emit-divide-loop (divisor rem quo tagged)
285 (let ((label-1 (gen-label))
286 (label-2 (gen-label)))
287 (inst cmp divisor rem)
288 (inst b :geu label-1)
293 (inst cmp divisor rem)
295 (inst b :gtu label-2)
297 (inst add quo (if tagged (fixnumize 1) 1))
298 (inst sub rem divisor)
299 (emit-label label-2))))))
300 (do-loop (if tagged 30 32))))
302 (define-assembly-routine (positive-fixnum-truncate
303 (:note "unsigned fixnum truncate")
305 (:translate truncate)
307 (:arg-types positive-fixnum positive-fixnum)
308 (:result-types positive-fixnum positive-fixnum))
309 ((:arg dividend any-reg nl0-offset)
310 (:arg divisor any-reg nl1-offset)
312 (:res quo any-reg nl2-offset)
313 (:res rem any-reg nl0-offset))
315 (let ((error (generate-error-code nil division-by-zero-error
321 (emit-divide-loop divisor rem quo t))
324 (define-assembly-routine (fixnum-truncate
325 (:note "fixnum truncate")
328 (:translate truncate)
329 (:arg-types tagged-num tagged-num)
330 (:result-types tagged-num tagged-num))
331 ((:arg dividend any-reg nl0-offset)
332 (:arg divisor any-reg nl1-offset)
334 (:res quo any-reg nl2-offset)
335 (:res rem any-reg nl0-offset)
337 (:temp quo-sign any-reg nl5-offset)
338 (:temp rem-sign any-reg nargs-offset))
340 (let ((error (generate-error-code nil division-by-zero-error
345 (inst xor quo-sign dividend divisor)
346 (inst move rem-sign dividend)
347 (let ((label (gen-label)))
352 (let ((label (gen-label)))
358 (emit-divide-loop divisor rem quo t)
359 (let ((label (gen-label)))
360 ;; If the quo-sign is negative, we need to negate quo.
365 (let ((label (gen-label)))
366 ;; If the rem-sign is negative, we need to negate rem.
373 (define-assembly-routine (signed-truncate
374 (:note "(signed-byte 32) truncate")
377 (:translate truncate)
378 (:arg-types signed-num signed-num)
379 (:result-types signed-num signed-num))
381 ((:arg dividend signed-reg nl0-offset)
382 (:arg divisor signed-reg nl1-offset)
384 (:res quo signed-reg nl2-offset)
385 (:res rem signed-reg nl0-offset)
387 (:temp quo-sign signed-reg nl5-offset)
388 (:temp rem-sign signed-reg nargs-offset))
390 (let ((error (generate-error-code nil division-by-zero-error
395 (inst xor quo-sign dividend divisor)
396 (inst move rem-sign dividend)
397 (let ((label (gen-label)))
402 (let ((label (gen-label)))
408 (emit-divide-loop divisor rem quo nil)
409 (let ((label (gen-label)))
410 ;; If the quo-sign is negative, we need to negate quo.
415 (let ((label (gen-label)))
416 ;; If the rem-sign is negative, we need to negate rem.
426 ((define-cond-assem-rtn (name translate static-fn cmp)
427 `(define-assembly-routine (,name
429 (:return-style :full-call)
431 (:translate ,translate)
433 ((:arg x (descriptor-reg any-reg) a0-offset)
434 (:arg y (descriptor-reg any-reg) a1-offset)
436 (:res res descriptor-reg a0-offset)
438 (:temp nargs any-reg nargs-offset)
439 (:temp ocfp any-reg ocfp-offset))
440 (inst andcc zero-tn x fixnum-tag-mask)
441 (inst b :ne DO-STATIC-FN)
442 (inst andcc zero-tn y fixnum-tag-mask)
443 (inst b :eq DO-COMPARE)
447 (inst ld code-tn null-tn (static-fun-offset ',static-fn))
448 (inst li nargs (fixnumize 2))
449 (inst move ocfp cfp-tn)
451 (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
452 (inst move cfp-tn csp-tn)
457 (inst move res null-tn)
460 (define-cond-assem-rtn generic-< < two-arg-< :lt)
461 (define-cond-assem-rtn generic-<= <= two-arg-<= :le)
462 (define-cond-assem-rtn generic-> > two-arg-> :gt)
463 (define-cond-assem-rtn generic->= >= two-arg->= :ge))
466 (define-assembly-routine (generic-eql
468 (:return-style :full-call)
472 ((:arg x (descriptor-reg any-reg) a0-offset)
473 (:arg y (descriptor-reg any-reg) a1-offset)
475 (:res res descriptor-reg a0-offset)
477 (:temp lra descriptor-reg lra-offset)
478 (:temp nargs any-reg nargs-offset)
479 (:temp ocfp any-reg ocfp-offset))
481 (inst b :eq RETURN-T)
482 (inst andcc zero-tn x fixnum-tag-mask)
483 (inst b :eq RETURN-NIL)
484 (inst andcc zero-tn y fixnum-tag-mask)
485 (inst b :ne DO-STATIC-FN)
489 (inst move res null-tn)
490 (lisp-return lra :offset 2)
493 (inst ld code-tn null-tn (static-fun-offset 'eql))
494 (inst li nargs (fixnumize 2))
495 (inst move ocfp cfp-tn)
497 (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
498 (inst move cfp-tn csp-tn)
503 (define-assembly-routine (generic-=
505 (:return-style :full-call)
509 ((:arg x (descriptor-reg any-reg) a0-offset)
510 (:arg y (descriptor-reg any-reg) a1-offset)
512 (:res res descriptor-reg a0-offset)
514 (:temp lra descriptor-reg lra-offset)
515 (:temp nargs any-reg nargs-offset)
516 (:temp ocfp any-reg ocfp-offset))
517 (inst andcc zero-tn x fixnum-tag-mask)
518 (inst b :ne DO-STATIC-FN)
519 (inst andcc zero-tn y fixnum-tag-mask)
520 (inst b :ne DO-STATIC-FN)
522 (inst b :eq RETURN-T)
525 (inst move res null-tn)
526 (lisp-return lra :offset 2)
529 (inst ld code-tn null-tn (static-fun-offset 'two-arg-=))
530 (inst li nargs (fixnumize 2))
531 (inst move ocfp cfp-tn)
533 (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
534 (inst move cfp-tn csp-tn)
539 (define-assembly-routine (generic-/=
541 (:return-style :full-call)
545 ((:arg x (descriptor-reg any-reg) a0-offset)
546 (:arg y (descriptor-reg any-reg) a1-offset)
548 (:res res descriptor-reg a0-offset)
550 (:temp lra descriptor-reg lra-offset)
551 (:temp nargs any-reg nargs-offset)
552 (:temp ocfp any-reg ocfp-offset))
554 (inst b :eq RETURN-NIL)
555 (inst andcc zero-tn x fixnum-tag-mask)
556 (inst b :ne DO-STATIC-FN)
557 (inst andcc zero-tn y fixnum-tag-mask)
558 (inst b :ne DO-STATIC-FN)
562 (lisp-return lra :offset 2)
565 (inst ld code-tn null-tn (static-fun-offset 'two-arg-=))
566 (inst li nargs (fixnumize 2))
567 (inst move ocfp cfp-tn)
569 (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
570 (inst move cfp-tn csp-tn)
573 (inst move res null-tn))