1 ;;;; the VM definition arithmetic VOPs for HPPA
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 ;;;; Unary operations.
16 (define-vop (fixnum-unop)
17 (:args (x :scs (any-reg)))
18 (:results (res :scs (any-reg)))
19 (:note "inline fixnum arithmetic")
20 (:arg-types tagged-num)
21 (:result-types tagged-num)
24 (define-vop (signed-unop)
25 (:args (x :scs (signed-reg)))
26 (:results (res :scs (signed-reg)))
27 (:note "inline (signed-byte 32) arithmetic")
28 (:arg-types signed-num)
29 (:result-types signed-num)
32 (define-vop (fast-negate/fixnum fixnum-unop)
35 (inst sub zero-tn x res)))
37 (define-vop (fast-negate/signed signed-unop)
40 (inst sub zero-tn x res)))
42 (define-vop (fast-lognot/fixnum fixnum-unop)
43 (:temporary (:scs (any-reg) :type fixnum :to (:result 0))
47 (inst li (fixnumize -1) temp)
48 (inst xor x temp res)))
50 (define-vop (fast-lognot/signed signed-unop)
53 (inst uaddcm zero-tn x res)))
55 ;;;; Binary fixnum operations.
57 ;;; Assume that any constant operand is the second arg...
59 (define-vop (fast-fixnum-binop)
60 (:args (x :target r :scs (any-reg))
61 (y :target r :scs (any-reg)))
62 (:arg-types tagged-num tagged-num)
63 (:results (r :scs (any-reg)))
64 (:result-types tagged-num)
65 (:note "inline fixnum arithmetic")
70 (define-vop (fast-unsigned-binop)
71 (:args (x :target r :scs (unsigned-reg))
72 (y :target r :scs (unsigned-reg)))
73 (:arg-types unsigned-num unsigned-num)
74 (:results (r :scs (unsigned-reg)))
75 (:result-types unsigned-num)
76 (:note "inline (unsigned-byte 32) arithmetic")
81 (define-vop (fast-signed-binop)
82 (:args (x :target r :scs (signed-reg))
83 (y :target r :scs (signed-reg)))
84 (:arg-types signed-num signed-num)
85 (:results (r :scs (signed-reg)))
86 (:result-types signed-num)
87 (:note "inline (signed-byte 32) arithmetic")
92 (defmacro define-binop (translate cost untagged-cost op &optional arg-swap)
94 (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
96 (:args (x :target r :scs (any-reg))
97 (y :target r :scs (any-reg)))
98 (:translate ,translate)
103 (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
105 (:args (x :target r :scs (signed-reg))
106 (y :target r :scs (signed-reg)))
107 (:translate ,translate)
108 (:generator ,untagged-cost
112 (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
114 (:args (x :target r :scs (unsigned-reg))
115 (y :target r :scs (unsigned-reg)))
116 (:translate ,translate)
117 (:generator ,untagged-cost
120 `(inst ,op x y r))))))
122 (define-binop + 2 6 add)
123 (define-binop - 2 6 sub)
124 (define-binop logior 1 2 or)
125 (define-binop logand 1 2 and)
126 (define-binop logandc1 1 2 andcm t)
127 (define-binop logandc2 1 2 andcm)
128 (define-binop logxor 1 2 xor)
130 (define-vop (fast-fixnum-c-binop fast-fixnum-binop)
131 (:args (x :target r :scs (any-reg)))
133 (:arg-types tagged-num (:constant integer)))
135 (define-vop (fast-signed-c-binop fast-signed-binop)
136 (:args (x :target r :scs (signed-reg)))
138 (:arg-types tagged-num (:constant integer)))
140 (define-vop (fast-unsigned-c-binop fast-unsigned-binop)
141 (:args (x :target r :scs (unsigned-reg)))
143 (:arg-types tagged-num (:constant integer)))
145 (defmacro define-c-binop (translate cost untagged-cost tagged-type
148 (define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
150 (:arg-types tagged-num (:constant ,tagged-type))
151 (:translate ,translate)
153 (let ((y (fixnumize y)))
155 (define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
157 (:arg-types signed-num (:constant ,untagged-type))
158 (:translate ,translate)
159 (:generator ,untagged-cost
161 (define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED=>UNSIGNED")
162 fast-unsigned-c-binop)
163 (:arg-types unsigned-num (:constant ,untagged-type))
164 (:translate ,translate)
165 (:generator ,untagged-cost
168 (define-c-binop + 1 3 (signed-byte 9) (signed-byte 11)
170 (define-c-binop - 1 3
171 (integer #.(- (1- (ash 1 9))) #.(ash 1 9))
172 (integer #.(- (1- (ash 1 11))) #.(ash 1 11))
173 (inst addi (- y) x r))
175 ;;; Special case fixnum + and - that trap on overflow. Useful when we don't
176 ;;; know that the result is going to be a fixnum.
178 (define-vop (fast-+/fixnum fast-+/fixnum=>fixnum)
179 (:results (r :scs (any-reg descriptor-reg)))
180 (:result-types (:or signed-num unsigned-num))
185 (define-vop (fast-+-c/fixnum fast-+-c/fixnum=>fixnum)
186 (:results (r :scs (any-reg descriptor-reg)))
187 (:result-types (:or signed-num unsigned-num))
190 (inst addio (fixnumize y) x r)))
192 (define-vop (fast--/fixnum fast--/fixnum=>fixnum)
193 (:results (r :scs (any-reg descriptor-reg)))
194 (:result-types (:or signed-num unsigned-num))
199 (define-vop (fast---c/fixnum fast---c/fixnum=>fixnum)
200 (:results (r :scs (any-reg descriptor-reg)))
201 (:result-types (:or signed-num unsigned-num))
204 (inst addio (- (fixnumize y)) x r)))
208 (define-vop (fast-ash/unsigned=>unsigned)
211 (:note "inline word ASH")
212 (:args (number :scs (unsigned-reg))
213 (count :scs (signed-reg)))
214 (:arg-types unsigned-num tagged-num)
215 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
216 (:results (result :scs (unsigned-reg)))
217 (:result-types unsigned-num)
219 (inst comb :>= count zero-tn positive :nullify t)
220 (inst sub zero-tn count temp)
221 (inst comiclr 31 temp zero-tn :>=)
223 (inst mtctl temp :sar)
224 (inst extrs number 0 1 temp)
226 (inst shd temp number :variable result)
228 (inst subi 31 count temp)
229 (inst mtctl temp :sar)
230 (inst zdep number :variable 32 result)
233 (define-vop (fast-ash/signed=>signed)
236 (:note "inline word ASH")
237 (:args (number :scs (signed-reg))
238 (count :scs (signed-reg)))
239 (:arg-types signed-num tagged-num)
240 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
241 (:results (result :scs (signed-reg)))
242 (:result-types signed-num)
244 (inst comb :>= count zero-tn positive :nullify t)
245 (inst sub zero-tn count temp)
246 (inst comiclr 31 temp zero-tn :>=)
248 (inst mtctl temp :sar)
249 (inst extrs number 0 1 temp)
251 (inst shd temp number :variable result)
253 (inst subi 31 count temp)
254 (inst mtctl temp :sar)
255 (inst zdep number :variable 32 result)
258 (define-vop (fast-ash-c/unsigned=>unsigned)
262 (:args (number :scs (unsigned-reg)))
264 (:arg-types unsigned-num (:constant integer))
265 (:results (result :scs (unsigned-reg)))
266 (:result-types unsigned-num)
269 ;; It is a right shift.
270 (inst srl number (min (- count) 31) result))
272 ;; It is a left shift.
273 (inst sll number (min count 31) result))
275 ;; Count=0? Shouldn't happen, but it's easy:
276 (move number result)))))
278 (define-vop (fast-ash-c/signed=>signed)
282 (:args (number :scs (signed-reg)))
284 (:arg-types signed-num (:constant integer))
285 (:results (result :scs (signed-reg)))
286 (:result-types signed-num)
289 ;; It is a right shift.
290 (inst sra number (min (- count) 31) result))
292 ;; It is a left shift.
293 (inst sll number (min count 31) result))
295 ;; Count=0? Shouldn't happen, but it's easy:
296 (move number result)))))
299 (define-vop (signed-byte-32-len)
300 (:translate integer-length)
301 (:note "inline (signed-byte 32) integer-length")
303 (:args (arg :scs (signed-reg) :target shift))
304 (:arg-types signed-num)
305 (:results (res :scs (any-reg)))
306 (:result-types positive-fixnum)
307 (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
309 (inst move arg shift :>=)
310 (inst uaddcm zero-tn shift shift)
311 (inst comb := shift zero-tn done)
314 (inst srl shift 1 shift)
315 (inst comb :<> shift zero-tn loop)
316 (inst addi (fixnumize 1) res res)
319 (define-vop (unsigned-byte-32-count)
320 (:translate logcount)
321 (:note "inline (unsigned-byte 32) logcount")
323 (:args (arg :scs (unsigned-reg) :target num))
324 (:arg-types unsigned-num)
325 (:results (res :scs (unsigned-reg)))
326 (:result-types positive-fixnum)
327 (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0)
329 (:temporary (:scs (non-descriptor-reg)) mask temp)
331 (inst li #x55555555 mask)
332 (inst srl arg 1 temp)
333 (inst and arg mask num)
334 (inst and temp mask temp)
335 (inst add num temp num)
336 (inst li #x33333333 mask)
337 (inst srl num 2 temp)
338 (inst and num mask num)
339 (inst and temp mask temp)
340 (inst add num temp num)
341 (inst li #x0f0f0f0f mask)
342 (inst srl num 4 temp)
343 (inst and num mask num)
344 (inst and temp mask temp)
345 (inst add num temp num)
346 (inst li #x00ff00ff mask)
347 (inst srl num 8 temp)
348 (inst and num mask num)
349 (inst and temp mask temp)
350 (inst add num temp num)
351 (inst li #x0000ffff mask)
352 (inst srl num 16 temp)
353 (inst and num mask num)
354 (inst and temp mask temp)
355 (inst add num temp res)))
357 ;;; Multiply and Divide.
359 (define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
360 (:args (x :scs (any-reg) :target x-pass)
361 (y :scs (any-reg) :target y-pass))
362 (:temporary (:sc signed-reg :offset nl0-offset
363 :from (:argument 0) :to (:result 0)) x-pass)
364 (:temporary (:sc signed-reg :offset nl1-offset
365 :from (:argument 1) :to (:result 0)) y-pass)
366 (:temporary (:sc signed-reg :offset nl2-offset :target r
367 :from (:argument 1) :to (:result 0)) res-pass)
368 (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp)
369 (:temporary (:sc signed-reg :offset nl4-offset
370 :from (:argument 1) :to (:result 0)) sign)
371 (:temporary (:sc interior-reg :offset lip-offset) lip)
375 (unless (location= y y-pass)
376 (inst sra x 2 x-pass))
377 (let ((fixup (make-fixup 'multiply :assembly-routine)))
378 (inst ldil fixup tmp)
379 (inst ble fixup lisp-heap-space tmp))
380 (if (location= y y-pass)
381 (inst sra x 2 x-pass)
382 (inst move y y-pass))
385 (define-vop (fast-*/signed=>signed fast-signed-binop)
387 (:args (x :scs (signed-reg) :target x-pass)
388 (y :scs (signed-reg) :target y-pass))
389 (:temporary (:sc signed-reg :offset nl0-offset
390 :from (:argument 0) :to (:result 0)) x-pass)
391 (:temporary (:sc signed-reg :offset nl1-offset
392 :from (:argument 1) :to (:result 0)) y-pass)
393 (:temporary (:sc signed-reg :offset nl2-offset :target r
394 :from (:argument 1) :to (:result 0)) res-pass)
395 (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp)
396 (:temporary (:sc signed-reg :offset nl4-offset
397 :from (:argument 1) :to (:result 0)) sign)
398 (:temporary (:sc interior-reg :offset lip-offset) lip)
402 (let ((fixup (make-fixup 'multiply :assembly-routine)))
405 (inst ldil fixup tmp)
406 (inst ble fixup lisp-heap-space tmp :nullify t)
410 (define-vop (fast-truncate/fixnum fast-fixnum-binop)
411 (:translate truncate)
412 (:args (x :scs (any-reg) :target x-pass)
413 (y :scs (any-reg) :target y-pass))
414 (:temporary (:sc signed-reg :offset nl0-offset
415 :from (:argument 0) :to (:result 0)) x-pass)
416 (:temporary (:sc signed-reg :offset nl1-offset
417 :from (:argument 1) :to (:result 0)) y-pass)
418 (:temporary (:sc signed-reg :offset nl2-offset :target q
419 :from (:argument 1) :to (:result 0)) q-pass)
420 (:temporary (:sc signed-reg :offset nl3-offset :target r
421 :from (:argument 1) :to (:result 1)) r-pass)
422 (:results (q :scs (signed-reg))
424 (:result-types tagged-num tagged-num)
426 (:save-p :compute-only)
428 (let ((zero (generate-error-code vop division-by-zero-error x y)))
429 (inst bc := nil y zero-tn zero))
432 (let ((fixup (make-fixup 'truncate :assembly-routine)))
433 (inst ldil fixup q-pass)
434 (inst ble fixup lisp-heap-space q-pass :nullify t))
439 (define-vop (fast-truncate/signed fast-signed-binop)
440 (:translate truncate)
441 (:args (x :scs (signed-reg) :target x-pass)
442 (y :scs (signed-reg) :target y-pass))
443 (:temporary (:sc signed-reg :offset nl0-offset
444 :from (:argument 0) :to (:result 0)) x-pass)
445 (:temporary (:sc signed-reg :offset nl1-offset
446 :from (:argument 1) :to (:result 0)) y-pass)
447 (:temporary (:sc signed-reg :offset nl2-offset :target q
448 :from (:argument 1) :to (:result 0)) q-pass)
449 (:temporary (:sc signed-reg :offset nl3-offset :target r
450 :from (:argument 1) :to (:result 1)) r-pass)
451 (:results (q :scs (signed-reg))
452 (r :scs (signed-reg)))
453 (:result-types signed-num signed-num)
455 (:save-p :compute-only)
457 (let ((zero (generate-error-code vop division-by-zero-error x y)))
458 (inst bc := nil y zero-tn zero))
461 (let ((fixup (make-fixup 'truncate :assembly-routine)))
462 (inst ldil fixup q-pass)
463 (inst ble fixup lisp-heap-space q-pass :nullify t))
469 ;;;; Binary conditional VOPs:
471 (define-vop (fast-conditional)
476 (:policy :fast-safe))
478 (define-vop (fast-conditional/fixnum fast-conditional)
479 (:args (x :scs (any-reg))
481 (:arg-types tagged-num tagged-num)
482 (:note "inline fixnum comparison"))
484 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
485 (:args (x :scs (any-reg)))
486 (:arg-types tagged-num (:constant (signed-byte 9)))
487 (:info target not-p y))
489 (define-vop (fast-conditional/signed fast-conditional)
490 (:args (x :scs (signed-reg))
491 (y :scs (signed-reg)))
492 (:arg-types signed-num signed-num)
493 (:note "inline (signed-byte 32) comparison"))
495 (define-vop (fast-conditional-c/signed fast-conditional/signed)
496 (:args (x :scs (signed-reg)))
497 (:arg-types signed-num (:constant (signed-byte 11)))
498 (:info target not-p y))
500 (define-vop (fast-conditional/unsigned fast-conditional)
501 (:args (x :scs (unsigned-reg))
502 (y :scs (unsigned-reg)))
503 (:arg-types unsigned-num unsigned-num)
504 (:note "inline (unsigned-byte 32) comparison"))
506 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
507 (:args (x :scs (unsigned-reg)))
508 (:arg-types unsigned-num (:constant (signed-byte 11)))
509 (:info target not-p y))
512 (defmacro define-conditional-vop (translate signed-cond unsigned-cond)
514 ,@(mapcar #'(lambda (suffix cost signed imm)
515 (unless (and (member suffix '(/fixnum -c/fixnum))
517 `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
520 (format nil "~:@(FAST-CONDITIONAL~A~)"
522 (:translate ,translate)
524 (inst ,(if imm 'bci 'bc)
525 ,(if signed signed-cond unsigned-cond)
527 ,(if (eq suffix '-c/fixnum)
532 '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
535 '(nil t nil t nil t))))
537 ;; We switch < and > because the immediate has to come first.
539 (define-conditional-vop < :> :>>)
540 (define-conditional-vop > :< :<<)
542 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
545 (define-conditional-vop eql := :=)
547 ;;; These versions specify a fixnum restriction on their first arg. We have
548 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
549 ;;; the first arg and a higher cost. The reason for doing this is to prevent
550 ;;; fixnum specific operations from being used on word integers, spuriously
551 ;;; consing the argument.
553 (define-vop (fast-eql/fixnum fast-conditional)
554 (:args (x :scs (any-reg descriptor-reg))
556 (:arg-types tagged-num tagged-num)
557 (:note "inline fixnum comparison")
560 (inst bc := not-p x y target)))
562 (define-vop (generic-eql/fixnum fast-eql/fixnum)
563 (:arg-types * tagged-num)
566 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
567 (:args (x :scs (any-reg descriptor-reg)))
568 (:arg-types tagged-num (:constant (signed-byte 9)))
569 (:info target not-p y)
572 (inst bci := not-p (fixnumize y) x target)))
574 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
575 (:arg-types * (:constant (signed-byte 9)))
579 ;;;; modular functions
580 (define-modular-fun +-mod32 (x y) + 32)
581 (define-vop (fast-+-mod32/unsigned=>unsigned fast-+/unsigned=>unsigned)
582 (:translate +-mod32))
583 (define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned)
584 (:translate +-mod32))
585 (define-modular-fun --mod32 (x y) - 32)
586 (define-vop (fast---mod32/unsigned=>unsigned fast--/unsigned=>unsigned)
587 (:translate --mod32))
588 (define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
589 (:translate --mod32))
591 (defknown ash-left-constant-mod32 (integer (integer 0)) (unsigned-byte 32)
592 (foldable flushable movable))
593 (define-vop (fast-ash-left-constant-mod32/unsigned=>unsigned
594 fast-ash-c/unsigned=>unsigned)
595 (:translate ash-left-constant-mod32))
597 (define-modular-fun lognot-mod32 (x) lognot 32)
598 (define-vop (lognot-mod32/unsigned=>unsigned)
599 (:translate lognot-mod32)
600 (:args (x :scs (unsigned-reg)))
601 (:arg-types unsigned-num)
602 (:results (res :scs (unsigned-reg)))
603 (:result-types unsigned-num)
606 (inst uaddcm zero-tn x res)))
609 ((define-modular-backend (fun)
610 (let ((mfun-name (symbolicate fun '-mod32))
611 ;; FIXME: if anyone cares, add constant-arg vops. --
613 (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
614 (vop (symbolicate 'fast- fun '/unsigned=>unsigned)))
616 (define-modular-fun ,mfun-name (x y) ,fun 32)
617 (define-vop (,modvop ,vop)
618 (:translate ,mfun-name))))))
619 (define-modular-backend logxor)
620 (define-modular-backend logandc1)
621 (define-modular-backend logandc2))
623 (define-source-transform logeqv (&rest args)
624 (if (oddp (length args))
626 `(lognot (logxor ,@args))))
627 (define-source-transform logorc1 (x y)
628 `(logior (lognot ,x) ,y))
629 (define-source-transform logorc2 (x y)
630 `(logior ,x (lognot ,y)))
631 (define-source-transform lognand (x y)
632 `(lognot (logand ,x ,y)))
633 (define-source-transform lognor (x y)
634 `(lognot (logior ,x y)))
636 ;;;; 32-bit logical operations
638 (define-source-transform 32bit-logical-not (x)
639 `(logand (lognot (the (unsigned-byte 32) ,x)) #.(1- (ash 1 32))))
641 (deftransform 32bit-logical-and ((x y))
644 (define-source-transform 32bit-logical-nand (x y)
645 `(32bit-logical-not (32bit-logical-and ,x ,y)))
647 (deftransform 32bit-logical-or ((x y))
650 (define-source-transform 32bit-logical-nor (x y)
651 `(logand (lognor (the (unsigned-byte 32) ,x) (the (unsigned-byte 32) ,y))
654 (deftransform 32bit-logical-xor ((x y))
657 (define-source-transform 32bit-logical-eqv (x y)
658 `(32bit-logical-not (32bit-logical-xor ,x ,y)))
660 (define-source-transform 32bit-logical-orc1 (x y)
661 `(32bit-logical-or (32bit-logical-not ,x) ,y))
663 (define-source-transform 32bit-logical-orc2 (x y)
664 `(32bit-logical-or ,x (32bit-logical-not ,y)))
666 (deftransform 32bit-logical-andc1 (x y)
669 (deftransform 32bit-logical-andc2 (x y)
672 (define-vop (shift-towards-someplace)
674 (:args (num :scs (unsigned-reg))
675 (amount :scs (signed-reg)))
676 (:arg-types unsigned-num tagged-num)
677 (:results (r :scs (unsigned-reg)))
678 (:result-types unsigned-num))
680 (define-vop (shift-towards-start shift-towards-someplace)
681 (:translate shift-towards-start)
682 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
683 (:note "SHIFT-TOWARDS-START")
685 (inst subi 31 amount temp)
686 (inst mtctl temp :sar)
687 (inst zdep num :variable 32 r)))
689 (define-vop (shift-towards-end shift-towards-someplace)
690 (:translate shift-towards-end)
691 (:note "SHIFT-TOWARDS-END")
693 (inst mtctl amount :sar)
694 (inst shd zero-tn num :variable r)))
700 (define-vop (bignum-length get-header-data)
701 (:translate sb!bignum::%bignum-length)
702 (:policy :fast-safe))
704 (define-vop (bignum-set-length set-header-data)
705 (:translate sb!bignum::%bignum-set-length)
706 (:policy :fast-safe))
708 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
709 (unsigned-reg) unsigned-num sb!bignum::%bignum-ref)
711 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
712 (unsigned-reg) unsigned-num sb!bignum::%bignum-set)
714 (define-vop (digit-0-or-plus)
715 (:translate sb!bignum::%digit-0-or-plusp)
717 (:args (digit :scs (unsigned-reg)))
718 (:arg-types unsigned-num)
724 (inst bc :>= not-p digit zero-tn target)))
726 (define-vop (add-w/carry)
727 (:translate sb!bignum::%add-with-carry)
729 (:args (a :scs (unsigned-reg))
730 (b :scs (unsigned-reg))
731 (c :scs (unsigned-reg)))
732 (:arg-types unsigned-num unsigned-num positive-fixnum)
733 (:results (result :scs (unsigned-reg))
734 (carry :scs (unsigned-reg)))
735 (:result-types unsigned-num positive-fixnum)
737 (inst addi -1 c zero-tn)
738 (inst addc a b result)
739 (inst addc zero-tn zero-tn carry)))
741 (define-vop (sub-w/borrow)
742 (:translate sb!bignum::%subtract-with-borrow)
744 (:args (a :scs (unsigned-reg))
745 (b :scs (unsigned-reg))
746 (c :scs (unsigned-reg)))
747 (:arg-types unsigned-num unsigned-num positive-fixnum)
748 (:results (result :scs (unsigned-reg))
749 (borrow :scs (unsigned-reg)))
750 (:result-types unsigned-num positive-fixnum)
752 (inst addi -1 c zero-tn)
753 (inst subb a b result)
754 (inst addc zero-tn zero-tn borrow)))
756 (define-vop (bignum-mult)
757 (:translate sb!bignum::%multiply)
759 (:args (x-arg :scs (unsigned-reg) :target x)
760 (y-arg :scs (unsigned-reg) :target y))
761 (:arg-types unsigned-num unsigned-num)
762 (:temporary (:scs (signed-reg) :from (:argument 0)) x)
763 (:temporary (:scs (signed-reg) :from (:argument 1)) y)
764 (:temporary (:scs (signed-reg)) tmp)
765 (:results (hi :scs (unsigned-reg))
766 (lo :scs (unsigned-reg)))
767 (:result-types unsigned-num unsigned-num)
769 ;; Make sure X is less then Y.
770 (inst comclr x-arg y-arg tmp :<<)
771 (inst xor x-arg y-arg tmp)
772 (inst xor x-arg tmp x)
773 (inst xor y-arg tmp y)
775 ;; Blow out of here if the result is zero.
777 (inst comb := x zero-tn done)
782 (inst comb :ev x zero-tn next-bit)
785 (inst addc hi tmp hi)
788 (inst comb :<> x zero-tn loop)
789 (inst addc tmp tmp tmp)
793 (define-source-transform sb!bignum:%multiply-and-add (x y carry &optional (extra 0))
794 #+nil ;; This would be greate if it worked, but it doesn't.
796 `(multiple-value-call #'sb!bignum::%dual-word-add
797 (sb!bignum:%multiply ,x ,y)
799 `(multiple-value-call #'sb!bignum::%dual-word-add
800 (multiple-value-call #'sb!bignum::%dual-word-add
801 (sb!bignum:%multiply ,x ,y)
804 (with-unique-names (hi lo)
806 `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
807 (sb!bignum::%dual-word-add ,hi ,lo ,carry))
808 `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
811 (sb!bignum::%dual-word-add ,hi ,lo ,carry)
812 (sb!bignum::%dual-word-add ,hi ,lo ,extra))))))
814 (defknown sb!bignum::%dual-word-add
815 (sb!bignum:bignum-element-type sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
816 (values sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
819 (define-vop (dual-word-add)
821 (:translate sb!bignum::%dual-word-add)
822 (:args (hi :scs (unsigned-reg) :to (:result 1))
823 (lo :scs (unsigned-reg))
824 (extra :scs (unsigned-reg)))
825 (:arg-types unsigned-num unsigned-num unsigned-num)
826 (:results (hi-res :scs (unsigned-reg) :from (:result 1))
827 (lo-res :scs (unsigned-reg) :from (:result 0)))
828 (:result-types unsigned-num unsigned-num)
832 (inst add lo extra lo-res)
833 (inst addc hi zero-tn hi-res)))
835 (define-vop (bignum-lognot)
836 (:translate sb!bignum::%lognot)
838 (:args (x :scs (unsigned-reg)))
839 (:arg-types unsigned-num)
840 (:results (r :scs (unsigned-reg)))
841 (:result-types unsigned-num)
843 (inst uaddcm zero-tn x r)))
845 (define-vop (fixnum-to-digit)
846 (:translate sb!bignum::%fixnum-to-digit)
848 (:args (fixnum :scs (signed-reg)))
849 (:arg-types tagged-num)
850 (:results (digit :scs (unsigned-reg)))
851 (:result-types unsigned-num)
853 (move fixnum digit)))
855 (define-vop (bignum-floor)
856 (:translate sb!bignum::%floor)
858 (:args (hi :scs (unsigned-reg) :to (:argument 1))
859 (lo :scs (unsigned-reg) :to (:argument 0))
860 (divisor :scs (unsigned-reg)))
861 (:arg-types unsigned-num unsigned-num unsigned-num)
862 (:temporary (:scs (unsigned-reg) :to (:argument 1)) temp)
863 (:results (quo :scs (unsigned-reg) :from (:argument 0))
864 (rem :scs (unsigned-reg) :from (:argument 1)))
865 (:result-types unsigned-num unsigned-num)
867 (inst sub zero-tn divisor temp)
868 (inst ds zero-tn temp zero-tn)
870 (inst ds hi divisor rem)
871 (inst addc quo quo quo)
873 (inst ds rem divisor rem)
874 (inst addc quo quo quo))
875 (inst comclr rem zero-tn zero-tn :>=)
876 (inst add divisor rem rem)))
878 (define-vop (signify-digit)
879 (:translate sb!bignum::%fixnum-digit-with-correct-sign)
881 (:args (digit :scs (unsigned-reg) :target res))
882 (:arg-types unsigned-num)
883 (:results (res :scs (signed-reg)))
884 (:result-types signed-num)
888 (define-vop (digit-lshr)
889 (:translate sb!bignum::%digit-logical-shift-right)
891 (:args (digit :scs (unsigned-reg))
892 (count :scs (unsigned-reg)))
893 (:arg-types unsigned-num positive-fixnum)
894 (:results (result :scs (unsigned-reg)))
895 (:result-types unsigned-num)
897 (inst mtctl count :sar)
898 (inst shd zero-tn digit :variable result)))
900 (define-vop (digit-ashr digit-lshr)
901 (:translate sb!bignum::%ashr)
902 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
904 (inst extrs digit 0 1 temp)
905 (inst mtctl count :sar)
906 (inst shd temp digit :variable result)))
908 (define-vop (digit-ashl digit-ashr)
909 (:translate sb!bignum::%ashl)
911 (inst subi 31 count temp)
912 (inst mtctl temp :sar)
913 (inst zdep digit :variable 32 result)))
916 ;;;; Static functions.
918 (define-static-fun two-arg-gcd (x y) :translate gcd)
919 (define-static-fun two-arg-lcm (x y) :translate lcm)
921 (define-static-fun two-arg-* (x y) :translate *)
922 (define-static-fun two-arg-/ (x y) :translate /)
924 (define-static-fun %negate (x) :translate %negate)
926 (define-static-fun two-arg-and (x y) :translate logand)
927 (define-static-fun two-arg-ior (x y) :translate logior)
928 (define-static-fun two-arg-xor (x y) :translate logxor)