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 (define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
592 fast-ash-c/unsigned=>unsigned)
593 (:translate ash-left-mod32))
595 (define-modular-fun lognot-mod32 (x) lognot 32)
596 (define-vop (lognot-mod32/unsigned=>unsigned)
597 (:translate lognot-mod32)
598 (:args (x :scs (unsigned-reg)))
599 (:arg-types unsigned-num)
600 (:results (res :scs (unsigned-reg)))
601 (:result-types unsigned-num)
604 (inst uaddcm zero-tn x res)))
607 ((define-modular-backend (fun)
608 (let ((mfun-name (symbolicate fun '-mod32))
609 ;; FIXME: if anyone cares, add constant-arg vops. --
611 (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
612 (vop (symbolicate 'fast- fun '/unsigned=>unsigned)))
614 (define-modular-fun ,mfun-name (x y) ,fun 32)
615 (define-vop (,modvop ,vop)
616 (:translate ,mfun-name))))))
617 (define-modular-backend logxor)
618 (define-modular-backend logandc1)
619 (define-modular-backend logandc2))
621 (define-source-transform logeqv (&rest args)
622 (if (oddp (length args))
624 `(lognot (logxor ,@args))))
625 (define-source-transform logorc1 (x y)
626 `(logior (lognot ,x) ,y))
627 (define-source-transform logorc2 (x y)
628 `(logior ,x (lognot ,y)))
629 (define-source-transform lognand (x y)
630 `(lognot (logand ,x ,y)))
631 (define-source-transform lognor (x y)
632 `(lognot (logior ,x y)))
634 (define-vop (shift-towards-someplace)
636 (:args (num :scs (unsigned-reg))
637 (amount :scs (signed-reg)))
638 (:arg-types unsigned-num tagged-num)
639 (:results (r :scs (unsigned-reg)))
640 (:result-types unsigned-num))
642 (define-vop (shift-towards-start shift-towards-someplace)
643 (:translate shift-towards-start)
644 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
645 (:note "SHIFT-TOWARDS-START")
647 (inst subi 31 amount temp)
648 (inst mtctl temp :sar)
649 (inst zdep num :variable 32 r)))
651 (define-vop (shift-towards-end shift-towards-someplace)
652 (:translate shift-towards-end)
653 (:note "SHIFT-TOWARDS-END")
655 (inst mtctl amount :sar)
656 (inst shd zero-tn num :variable r)))
662 (define-vop (bignum-length get-header-data)
663 (:translate sb!bignum:%bignum-length)
664 (:policy :fast-safe))
666 (define-vop (bignum-set-length set-header-data)
667 (:translate sb!bignum:%bignum-set-length)
668 (:policy :fast-safe))
670 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
671 (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
673 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
674 (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
676 (define-vop (digit-0-or-plus)
677 (:translate sb!bignum:%digit-0-or-plusp)
679 (:args (digit :scs (unsigned-reg)))
680 (:arg-types unsigned-num)
686 (inst bc :>= not-p digit zero-tn target)))
688 (define-vop (add-w/carry)
689 (:translate sb!bignum:%add-with-carry)
691 (:args (a :scs (unsigned-reg))
692 (b :scs (unsigned-reg))
693 (c :scs (unsigned-reg)))
694 (:arg-types unsigned-num unsigned-num positive-fixnum)
695 (:results (result :scs (unsigned-reg))
696 (carry :scs (unsigned-reg)))
697 (:result-types unsigned-num positive-fixnum)
699 (inst addi -1 c zero-tn)
700 (inst addc a b result)
701 (inst addc zero-tn zero-tn carry)))
703 (define-vop (sub-w/borrow)
704 (:translate sb!bignum:%subtract-with-borrow)
706 (:args (a :scs (unsigned-reg))
707 (b :scs (unsigned-reg))
708 (c :scs (unsigned-reg)))
709 (:arg-types unsigned-num unsigned-num positive-fixnum)
710 (:results (result :scs (unsigned-reg))
711 (borrow :scs (unsigned-reg)))
712 (:result-types unsigned-num positive-fixnum)
714 (inst addi -1 c zero-tn)
715 (inst subb a b result)
716 (inst addc zero-tn zero-tn borrow)))
718 (define-vop (bignum-mult)
719 (:translate sb!bignum:%multiply)
721 (:args (x-arg :scs (unsigned-reg) :target x)
722 (y-arg :scs (unsigned-reg) :target y))
723 (:arg-types unsigned-num unsigned-num)
724 (:temporary (:scs (signed-reg) :from (:argument 0)) x)
725 (:temporary (:scs (signed-reg) :from (:argument 1)) y)
726 (:temporary (:scs (signed-reg)) tmp)
727 (:results (hi :scs (unsigned-reg))
728 (lo :scs (unsigned-reg)))
729 (:result-types unsigned-num unsigned-num)
731 ;; Make sure X is less then Y.
732 (inst comclr x-arg y-arg tmp :<<)
733 (inst xor x-arg y-arg tmp)
734 (inst xor x-arg tmp x)
735 (inst xor y-arg tmp y)
737 ;; Blow out of here if the result is zero.
739 (inst comb := x zero-tn done)
744 (inst comb :ev x zero-tn next-bit)
747 (inst addc hi tmp hi)
750 (inst comb :<> x zero-tn loop)
751 (inst addc tmp tmp tmp)
755 (define-source-transform sb!bignum:%multiply-and-add (x y carry &optional (extra 0))
756 #+nil ;; This would be greate if it worked, but it doesn't.
758 `(multiple-value-call #'sb!bignum:%dual-word-add
759 (sb!bignum:%multiply ,x ,y)
761 `(multiple-value-call #'sb!bignum:%dual-word-add
762 (multiple-value-call #'sb!bignum:%dual-word-add
763 (sb!bignum:%multiply ,x ,y)
766 (with-unique-names (hi lo)
768 `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
769 (sb!bignum::%dual-word-add ,hi ,lo ,carry))
770 `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
773 (sb!bignum::%dual-word-add ,hi ,lo ,carry)
774 (sb!bignum::%dual-word-add ,hi ,lo ,extra))))))
776 (defknown sb!bignum::%dual-word-add
777 (sb!bignum:bignum-element-type sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
778 (values sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
781 (define-vop (dual-word-add)
783 (:translate sb!bignum::%dual-word-add)
784 (:args (hi :scs (unsigned-reg) :to (:result 1))
785 (lo :scs (unsigned-reg))
786 (extra :scs (unsigned-reg)))
787 (:arg-types unsigned-num unsigned-num unsigned-num)
788 (:results (hi-res :scs (unsigned-reg) :from (:result 1))
789 (lo-res :scs (unsigned-reg) :from (:result 0)))
790 (:result-types unsigned-num unsigned-num)
794 (inst add lo extra lo-res)
795 (inst addc hi zero-tn hi-res)))
797 (define-vop (bignum-lognot)
798 (:translate sb!bignum:%lognot)
800 (:args (x :scs (unsigned-reg)))
801 (:arg-types unsigned-num)
802 (:results (r :scs (unsigned-reg)))
803 (:result-types unsigned-num)
805 (inst uaddcm zero-tn x r)))
807 (define-vop (fixnum-to-digit)
808 (:translate sb!bignum:%fixnum-to-digit)
810 (:args (fixnum :scs (signed-reg)))
811 (:arg-types tagged-num)
812 (:results (digit :scs (unsigned-reg)))
813 (:result-types unsigned-num)
815 (move fixnum digit)))
817 (define-vop (bignum-floor)
818 (:translate sb!bignum:%floor)
820 (:args (hi :scs (unsigned-reg) :to (:argument 1))
821 (lo :scs (unsigned-reg) :to (:argument 0))
822 (divisor :scs (unsigned-reg)))
823 (:arg-types unsigned-num unsigned-num unsigned-num)
824 (:temporary (:scs (unsigned-reg) :to (:argument 1)) temp)
825 (:results (quo :scs (unsigned-reg) :from (:argument 0))
826 (rem :scs (unsigned-reg) :from (:argument 1)))
827 (:result-types unsigned-num unsigned-num)
829 (inst sub zero-tn divisor temp)
830 (inst ds zero-tn temp zero-tn)
832 (inst ds hi divisor rem)
833 (inst addc quo quo quo)
835 (inst ds rem divisor rem)
836 (inst addc quo quo quo))
837 (inst comclr rem zero-tn zero-tn :>=)
838 (inst add divisor rem rem)))
840 (define-vop (signify-digit)
841 (:translate sb!bignum:%fixnum-digit-with-correct-sign)
843 (:args (digit :scs (unsigned-reg) :target res))
844 (:arg-types unsigned-num)
845 (:results (res :scs (signed-reg)))
846 (:result-types signed-num)
850 (define-vop (digit-lshr)
851 (:translate sb!bignum:%digit-logical-shift-right)
853 (:args (digit :scs (unsigned-reg))
854 (count :scs (unsigned-reg)))
855 (:arg-types unsigned-num positive-fixnum)
856 (:results (result :scs (unsigned-reg)))
857 (:result-types unsigned-num)
859 (inst mtctl count :sar)
860 (inst shd zero-tn digit :variable result)))
862 (define-vop (digit-ashr digit-lshr)
863 (:translate sb!bignum:%ashr)
864 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
866 (inst extrs digit 0 1 temp)
867 (inst mtctl count :sar)
868 (inst shd temp digit :variable result)))
870 (define-vop (digit-ashl digit-ashr)
871 (:translate sb!bignum:%ashl)
873 (inst subi 31 count temp)
874 (inst mtctl temp :sar)
875 (inst zdep digit :variable 32 result)))
878 ;;;; Static functions.
880 (define-static-fun two-arg-gcd (x y) :translate gcd)
881 (define-static-fun two-arg-lcm (x y) :translate lcm)
883 (define-static-fun two-arg-* (x y) :translate *)
884 (define-static-fun two-arg-/ (x y) :translate /)
886 (define-static-fun %negate (x) :translate %negate)
888 (define-static-fun two-arg-and (x y) :translate logand)
889 (define-static-fun two-arg-ior (x y) :translate logior)
890 (define-static-fun two-arg-xor (x y) :translate logxor)