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)))))
298 ;;; FIXME: implement FAST-ASH-LEFT/UNSIGNED=>UNSIGNED and friends, for
299 ;;; use in modular ASH (and because they're useful anyway). -- CSR,
302 (define-vop (signed-byte-32-len)
303 (:translate integer-length)
304 (:note "inline (signed-byte 32) integer-length")
306 (:args (arg :scs (signed-reg) :target shift))
307 (:arg-types signed-num)
308 (:results (res :scs (any-reg)))
309 (:result-types positive-fixnum)
310 (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
312 (inst move arg shift :>=)
313 (inst uaddcm zero-tn shift shift)
314 (inst comb := shift zero-tn done)
317 (inst srl shift 1 shift)
318 (inst comb :<> shift zero-tn loop)
319 (inst addi (fixnumize 1) res res)
322 (define-vop (unsigned-byte-32-count)
323 (:translate logcount)
324 (:note "inline (unsigned-byte 32) logcount")
326 (:args (arg :scs (unsigned-reg) :target num))
327 (:arg-types unsigned-num)
328 (:results (res :scs (unsigned-reg)))
329 (:result-types positive-fixnum)
330 (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0)
332 (:temporary (:scs (non-descriptor-reg)) mask temp)
334 (inst li #x55555555 mask)
335 (inst srl arg 1 temp)
336 (inst and arg mask num)
337 (inst and temp mask temp)
338 (inst add num temp num)
339 (inst li #x33333333 mask)
340 (inst srl num 2 temp)
341 (inst and num mask num)
342 (inst and temp mask temp)
343 (inst add num temp num)
344 (inst li #x0f0f0f0f mask)
345 (inst srl num 4 temp)
346 (inst and num mask num)
347 (inst and temp mask temp)
348 (inst add num temp num)
349 (inst li #x00ff00ff mask)
350 (inst srl num 8 temp)
351 (inst and num mask num)
352 (inst and temp mask temp)
353 (inst add num temp num)
354 (inst li #x0000ffff mask)
355 (inst srl num 16 temp)
356 (inst and num mask num)
357 (inst and temp mask temp)
358 (inst add num temp res)))
360 ;;; Multiply and Divide.
362 (define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
363 (:args (x :scs (any-reg) :target x-pass)
364 (y :scs (any-reg) :target y-pass))
365 (:temporary (:sc signed-reg :offset nl0-offset
366 :from (:argument 0) :to (:result 0)) x-pass)
367 (:temporary (:sc signed-reg :offset nl1-offset
368 :from (:argument 1) :to (:result 0)) y-pass)
369 (:temporary (:sc signed-reg :offset nl2-offset :target r
370 :from (:argument 1) :to (:result 0)) res-pass)
371 (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp)
372 (:temporary (:sc signed-reg :offset nl4-offset
373 :from (:argument 1) :to (:result 0)) sign)
374 (:temporary (:sc interior-reg :offset lip-offset) lip)
378 (unless (location= y y-pass)
379 (inst sra x 2 x-pass))
380 (let ((fixup (make-fixup 'multiply :assembly-routine)))
381 (inst ldil fixup tmp)
382 (inst ble fixup lisp-heap-space tmp))
383 (if (location= y y-pass)
384 (inst sra x 2 x-pass)
385 (inst move y y-pass))
388 (define-vop (fast-*/signed=>signed fast-signed-binop)
390 (:args (x :scs (signed-reg) :target x-pass)
391 (y :scs (signed-reg) :target y-pass))
392 (:temporary (:sc signed-reg :offset nl0-offset
393 :from (:argument 0) :to (:result 0)) x-pass)
394 (:temporary (:sc signed-reg :offset nl1-offset
395 :from (:argument 1) :to (:result 0)) y-pass)
396 (:temporary (:sc signed-reg :offset nl2-offset :target r
397 :from (:argument 1) :to (:result 0)) res-pass)
398 (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp)
399 (:temporary (:sc signed-reg :offset nl4-offset
400 :from (:argument 1) :to (:result 0)) sign)
401 (:temporary (:sc interior-reg :offset lip-offset) lip)
405 (let ((fixup (make-fixup 'multiply :assembly-routine)))
408 (inst ldil fixup tmp)
409 (inst ble fixup lisp-heap-space tmp :nullify t)
413 (define-vop (fast-truncate/fixnum fast-fixnum-binop)
414 (:translate truncate)
415 (:args (x :scs (any-reg) :target x-pass)
416 (y :scs (any-reg) :target y-pass))
417 (:temporary (:sc signed-reg :offset nl0-offset
418 :from (:argument 0) :to (:result 0)) x-pass)
419 (:temporary (:sc signed-reg :offset nl1-offset
420 :from (:argument 1) :to (:result 0)) y-pass)
421 (:temporary (:sc signed-reg :offset nl2-offset :target q
422 :from (:argument 1) :to (:result 0)) q-pass)
423 (:temporary (:sc signed-reg :offset nl3-offset :target r
424 :from (:argument 1) :to (:result 1)) r-pass)
425 (:results (q :scs (signed-reg))
427 (:result-types tagged-num tagged-num)
429 (:save-p :compute-only)
431 (let ((zero (generate-error-code vop division-by-zero-error x y)))
432 (inst bc := nil y zero-tn zero))
435 (let ((fixup (make-fixup 'truncate :assembly-routine)))
436 (inst ldil fixup q-pass)
437 (inst ble fixup lisp-heap-space q-pass :nullify t))
442 (define-vop (fast-truncate/signed fast-signed-binop)
443 (:translate truncate)
444 (:args (x :scs (signed-reg) :target x-pass)
445 (y :scs (signed-reg) :target y-pass))
446 (:temporary (:sc signed-reg :offset nl0-offset
447 :from (:argument 0) :to (:result 0)) x-pass)
448 (:temporary (:sc signed-reg :offset nl1-offset
449 :from (:argument 1) :to (:result 0)) y-pass)
450 (:temporary (:sc signed-reg :offset nl2-offset :target q
451 :from (:argument 1) :to (:result 0)) q-pass)
452 (:temporary (:sc signed-reg :offset nl3-offset :target r
453 :from (:argument 1) :to (:result 1)) r-pass)
454 (:results (q :scs (signed-reg))
455 (r :scs (signed-reg)))
456 (:result-types signed-num signed-num)
458 (:save-p :compute-only)
460 (let ((zero (generate-error-code vop division-by-zero-error x y)))
461 (inst bc := nil y zero-tn zero))
464 (let ((fixup (make-fixup 'truncate :assembly-routine)))
465 (inst ldil fixup q-pass)
466 (inst ble fixup lisp-heap-space q-pass :nullify t))
472 ;;;; Binary conditional VOPs:
474 (define-vop (fast-conditional)
479 (:policy :fast-safe))
481 (define-vop (fast-conditional/fixnum fast-conditional)
482 (:args (x :scs (any-reg))
484 (:arg-types tagged-num tagged-num)
485 (:note "inline fixnum comparison"))
487 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
488 (:args (x :scs (any-reg)))
489 (:arg-types tagged-num (:constant (signed-byte 9)))
490 (:info target not-p y))
492 (define-vop (fast-conditional/signed fast-conditional)
493 (:args (x :scs (signed-reg))
494 (y :scs (signed-reg)))
495 (:arg-types signed-num signed-num)
496 (:note "inline (signed-byte 32) comparison"))
498 (define-vop (fast-conditional-c/signed fast-conditional/signed)
499 (:args (x :scs (signed-reg)))
500 (:arg-types signed-num (:constant (signed-byte 11)))
501 (:info target not-p y))
503 (define-vop (fast-conditional/unsigned fast-conditional)
504 (:args (x :scs (unsigned-reg))
505 (y :scs (unsigned-reg)))
506 (:arg-types unsigned-num unsigned-num)
507 (:note "inline (unsigned-byte 32) comparison"))
509 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
510 (:args (x :scs (unsigned-reg)))
511 (:arg-types unsigned-num (:constant (signed-byte 11)))
512 (:info target not-p y))
515 (defmacro define-conditional-vop (translate signed-cond unsigned-cond)
517 ,@(mapcar #'(lambda (suffix cost signed imm)
518 (unless (and (member suffix '(/fixnum -c/fixnum))
520 `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
523 (format nil "~:@(FAST-CONDITIONAL~A~)"
525 (:translate ,translate)
527 (inst ,(if imm 'bci 'bc)
528 ,(if signed signed-cond unsigned-cond)
530 ,(if (eq suffix '-c/fixnum)
535 '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
538 '(nil t nil t nil t))))
540 ;; We switch < and > because the immediate has to come first.
542 (define-conditional-vop < :> :>>)
543 (define-conditional-vop > :< :<<)
545 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
548 (define-conditional-vop eql := :=)
550 ;;; These versions specify a fixnum restriction on their first arg. We have
551 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
552 ;;; the first arg and a higher cost. The reason for doing this is to prevent
553 ;;; fixnum specific operations from being used on word integers, spuriously
554 ;;; consing the argument.
556 (define-vop (fast-eql/fixnum fast-conditional)
557 (:args (x :scs (any-reg descriptor-reg))
559 (:arg-types tagged-num tagged-num)
560 (:note "inline fixnum comparison")
563 (inst bc := not-p x y target)))
565 (define-vop (generic-eql/fixnum fast-eql/fixnum)
566 (:arg-types * tagged-num)
569 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
570 (:args (x :scs (any-reg descriptor-reg)))
571 (:arg-types tagged-num (:constant (signed-byte 9)))
572 (:info target not-p y)
575 (inst bci := not-p (fixnumize y) x target)))
577 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
578 (:arg-types * (:constant (signed-byte 9)))
582 ;;;; modular functions
584 (macrolet ((define-modular-backend (fun &optional constantp)
586 (dolist (info '((29 fixnum) (32 unsigned)))
587 (destructuring-bind (width regtype) info
588 (let ((mfun-name (intern (format nil "~A-MOD~A" fun width)))
589 (mvop (intern (format nil "FAST-~A-MOD~A/~A=>~A"
590 fun width regtype regtype)))
591 (mcvop (intern (format nil "FAST-~A-MOD~A-C/~A=>~A"
592 fun width regtype regtype)))
593 (vop (intern (format nil "FAST-~A/~A=>~A"
594 fun regtype regtype)))
595 (cvop (intern (format nil "FAST-~A-C/~A=>~A"
596 fun regtype regtype))))
597 (forms `(define-modular-fun ,mfun-name (x y) ,fun ,width))
598 (forms `(define-vop (,mvop ,vop)
599 (:translate ,mfun-name)))
601 (forms `(define-vop (,mcvop ,cvop)
602 (:translate ,mfun-name)))))))
603 `(progn ,@(forms)))))
604 (define-modular-backend + t)
605 (define-modular-backend - t)
606 ;; FIXME: constant versions of these could be defined if anybody
607 ;; cared enough to implement them. -- CSR/NJF
608 (define-modular-backend logxor)
609 (define-modular-backend logandc1)
610 (define-modular-backend logandc2))
612 (define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
613 fast-ash-c/unsigned=>unsigned)
614 (:translate ash-left-mod32))
615 (define-vop (fast-ash-left-mod32/unsigned=>unsigned
616 ;; FIXME: when FAST-ASH-LEFT/UNSIGNED=>UNSIGNED is
617 ;; implemented, use it here. -- CSR, 2004-08-16
618 fast-ash/unsigned=>unsigned))
619 (deftransform ash-left-mod32 ((integer count)
620 ((unsigned-byte 32) (unsigned-byte 5)))
621 (when (sb!c::constant-lvar-p count)
622 (sb!c::give-up-ir1-transform))
623 '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
625 (define-modular-fun lognot-mod32 (x) lognot 32)
626 (define-vop (lognot-mod32/unsigned=>unsigned)
627 (:translate lognot-mod32)
628 (:args (x :scs (unsigned-reg)))
629 (:arg-types unsigned-num)
630 (:results (res :scs (unsigned-reg)))
631 (:result-types unsigned-num)
634 (inst uaddcm zero-tn x res)))
636 (define-source-transform logeqv (&rest args)
637 (if (oddp (length args))
639 `(lognot (logxor ,@args))))
640 (define-source-transform logorc1 (x y)
641 `(logior (lognot ,x) ,y))
642 (define-source-transform logorc2 (x y)
643 `(logior ,x (lognot ,y)))
644 (define-source-transform lognand (x y)
645 `(lognot (logand ,x ,y)))
646 (define-source-transform lognor (x y)
647 `(lognot (logior ,x y)))
649 (define-vop (shift-towards-someplace)
651 (:args (num :scs (unsigned-reg))
652 (amount :scs (signed-reg)))
653 (:arg-types unsigned-num tagged-num)
654 (:results (r :scs (unsigned-reg)))
655 (:result-types unsigned-num))
657 (define-vop (shift-towards-start shift-towards-someplace)
658 (:translate shift-towards-start)
659 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
660 (:note "SHIFT-TOWARDS-START")
662 (inst subi 31 amount temp)
663 (inst mtctl temp :sar)
664 (inst zdep num :variable 32 r)))
666 (define-vop (shift-towards-end shift-towards-someplace)
667 (:translate shift-towards-end)
668 (:note "SHIFT-TOWARDS-END")
670 (inst mtctl amount :sar)
671 (inst shd zero-tn num :variable r)))
677 (define-vop (bignum-length get-header-data)
678 (:translate sb!bignum:%bignum-length)
679 (:policy :fast-safe))
681 (define-vop (bignum-set-length set-header-data)
682 (:translate sb!bignum:%bignum-set-length)
683 (:policy :fast-safe))
685 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
686 (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
688 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
689 (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
691 (define-vop (digit-0-or-plus)
692 (:translate sb!bignum:%digit-0-or-plusp)
694 (:args (digit :scs (unsigned-reg)))
695 (:arg-types unsigned-num)
701 (inst bc :>= not-p digit zero-tn target)))
703 (define-vop (add-w/carry)
704 (:translate sb!bignum:%add-with-carry)
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 (carry :scs (unsigned-reg)))
712 (:result-types unsigned-num positive-fixnum)
714 (inst addi -1 c zero-tn)
715 (inst addc a b result)
716 (inst addc zero-tn zero-tn carry)))
718 (define-vop (sub-w/borrow)
719 (:translate sb!bignum:%subtract-with-borrow)
721 (:args (a :scs (unsigned-reg))
722 (b :scs (unsigned-reg))
723 (c :scs (unsigned-reg)))
724 (:arg-types unsigned-num unsigned-num positive-fixnum)
725 (:results (result :scs (unsigned-reg))
726 (borrow :scs (unsigned-reg)))
727 (:result-types unsigned-num positive-fixnum)
729 (inst addi -1 c zero-tn)
730 (inst subb a b result)
731 (inst addc zero-tn zero-tn borrow)))
733 (define-vop (bignum-mult)
734 (:translate sb!bignum:%multiply)
736 (:args (x-arg :scs (unsigned-reg) :target x)
737 (y-arg :scs (unsigned-reg) :target y))
738 (:arg-types unsigned-num unsigned-num)
739 (:temporary (:scs (signed-reg) :from (:argument 0)) x)
740 (:temporary (:scs (signed-reg) :from (:argument 1)) y)
741 (:temporary (:scs (signed-reg)) tmp)
742 (:results (hi :scs (unsigned-reg))
743 (lo :scs (unsigned-reg)))
744 (:result-types unsigned-num unsigned-num)
746 ;; Make sure X is less then Y.
747 (inst comclr x-arg y-arg tmp :<<)
748 (inst xor x-arg y-arg tmp)
749 (inst xor x-arg tmp x)
750 (inst xor y-arg tmp y)
752 ;; Blow out of here if the result is zero.
754 (inst comb := x zero-tn done)
759 (inst comb :ev x zero-tn next-bit)
762 (inst addc hi tmp hi)
765 (inst comb :<> x zero-tn loop)
766 (inst addc tmp tmp tmp)
770 (define-source-transform sb!bignum:%multiply-and-add (x y carry &optional (extra 0))
771 #+nil ;; This would be greate if it worked, but it doesn't.
773 `(multiple-value-call #'sb!bignum:%dual-word-add
774 (sb!bignum:%multiply ,x ,y)
776 `(multiple-value-call #'sb!bignum:%dual-word-add
777 (multiple-value-call #'sb!bignum:%dual-word-add
778 (sb!bignum:%multiply ,x ,y)
781 (with-unique-names (hi lo)
783 `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
784 (sb!bignum::%dual-word-add ,hi ,lo ,carry))
785 `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
788 (sb!bignum::%dual-word-add ,hi ,lo ,carry)
789 (sb!bignum::%dual-word-add ,hi ,lo ,extra))))))
791 (defknown sb!bignum::%dual-word-add
792 (sb!bignum:bignum-element-type sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
793 (values sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
796 (define-vop (dual-word-add)
798 (:translate sb!bignum::%dual-word-add)
799 (:args (hi :scs (unsigned-reg) :to (:result 1))
800 (lo :scs (unsigned-reg))
801 (extra :scs (unsigned-reg)))
802 (:arg-types unsigned-num unsigned-num unsigned-num)
803 (:results (hi-res :scs (unsigned-reg) :from (:result 1))
804 (lo-res :scs (unsigned-reg) :from (:result 0)))
805 (:result-types unsigned-num unsigned-num)
809 (inst add lo extra lo-res)
810 (inst addc hi zero-tn hi-res)))
812 (define-vop (bignum-lognot)
813 (:translate sb!bignum:%lognot)
815 (:args (x :scs (unsigned-reg)))
816 (:arg-types unsigned-num)
817 (:results (r :scs (unsigned-reg)))
818 (:result-types unsigned-num)
820 (inst uaddcm zero-tn x r)))
822 (define-vop (fixnum-to-digit)
823 (:translate sb!bignum:%fixnum-to-digit)
825 (:args (fixnum :scs (signed-reg)))
826 (:arg-types tagged-num)
827 (:results (digit :scs (unsigned-reg)))
828 (:result-types unsigned-num)
830 (move fixnum digit)))
832 (define-vop (bignum-floor)
833 (:translate sb!bignum:%floor)
835 (:args (hi :scs (unsigned-reg) :to (:argument 1))
836 (lo :scs (unsigned-reg) :to (:argument 0))
837 (divisor :scs (unsigned-reg)))
838 (:arg-types unsigned-num unsigned-num unsigned-num)
839 (:temporary (:scs (unsigned-reg) :to (:argument 1)) temp)
840 (:results (quo :scs (unsigned-reg) :from (:argument 0))
841 (rem :scs (unsigned-reg) :from (:argument 1)))
842 (:result-types unsigned-num unsigned-num)
844 (inst sub zero-tn divisor temp)
845 (inst ds zero-tn temp zero-tn)
847 (inst ds hi divisor rem)
848 (inst addc quo quo quo)
850 (inst ds rem divisor rem)
851 (inst addc quo quo quo))
852 (inst comclr rem zero-tn zero-tn :>=)
853 (inst add divisor rem rem)))
855 (define-vop (signify-digit)
856 (:translate sb!bignum:%fixnum-digit-with-correct-sign)
858 (:args (digit :scs (unsigned-reg) :target res))
859 (:arg-types unsigned-num)
860 (:results (res :scs (signed-reg)))
861 (:result-types signed-num)
865 (define-vop (digit-lshr)
866 (:translate sb!bignum:%digit-logical-shift-right)
868 (:args (digit :scs (unsigned-reg))
869 (count :scs (unsigned-reg)))
870 (:arg-types unsigned-num positive-fixnum)
871 (:results (result :scs (unsigned-reg)))
872 (:result-types unsigned-num)
874 (inst mtctl count :sar)
875 (inst shd zero-tn digit :variable result)))
877 (define-vop (digit-ashr digit-lshr)
878 (:translate sb!bignum:%ashr)
879 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
881 (inst extrs digit 0 1 temp)
882 (inst mtctl count :sar)
883 (inst shd temp digit :variable result)))
885 (define-vop (digit-ashl digit-ashr)
886 (:translate sb!bignum:%ashl)
888 (inst subi 31 count temp)
889 (inst mtctl temp :sar)
890 (inst zdep digit :variable 32 result)))
893 ;;;; Static functions.
895 (define-static-fun two-arg-gcd (x y) :translate gcd)
896 (define-static-fun two-arg-lcm (x y) :translate lcm)
898 (define-static-fun two-arg-* (x y) :translate *)
899 (define-static-fun two-arg-/ (x y) :translate /)
901 (define-static-fun %negate (x) :translate %negate)
903 (define-static-fun two-arg-and (x y) :translate logand)
904 (define-static-fun two-arg-ior (x y) :translate logior)
905 (define-static-fun two-arg-xor (x y) :translate logxor)