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 ;;;; 32-bit logical operations
636 (define-source-transform 32bit-logical-not (x)
637 `(logand (lognot (the (unsigned-byte 32) ,x)) #.(1- (ash 1 32))))
639 (deftransform 32bit-logical-and ((x y))
642 (define-source-transform 32bit-logical-nand (x y)
643 `(32bit-logical-not (32bit-logical-and ,x ,y)))
645 (deftransform 32bit-logical-or ((x y))
648 (define-source-transform 32bit-logical-nor (x y)
649 `(logand (lognor (the (unsigned-byte 32) ,x) (the (unsigned-byte 32) ,y))
652 (deftransform 32bit-logical-xor ((x y))
655 (define-source-transform 32bit-logical-eqv (x y)
656 `(32bit-logical-not (32bit-logical-xor ,x ,y)))
658 (define-source-transform 32bit-logical-orc1 (x y)
659 `(32bit-logical-or (32bit-logical-not ,x) ,y))
661 (define-source-transform 32bit-logical-orc2 (x y)
662 `(32bit-logical-or ,x (32bit-logical-not ,y)))
664 (deftransform 32bit-logical-andc1 (x y)
667 (deftransform 32bit-logical-andc2 (x y)
670 (define-vop (shift-towards-someplace)
672 (:args (num :scs (unsigned-reg))
673 (amount :scs (signed-reg)))
674 (:arg-types unsigned-num tagged-num)
675 (:results (r :scs (unsigned-reg)))
676 (:result-types unsigned-num))
678 (define-vop (shift-towards-start shift-towards-someplace)
679 (:translate shift-towards-start)
680 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
681 (:note "SHIFT-TOWARDS-START")
683 (inst subi 31 amount temp)
684 (inst mtctl temp :sar)
685 (inst zdep num :variable 32 r)))
687 (define-vop (shift-towards-end shift-towards-someplace)
688 (:translate shift-towards-end)
689 (:note "SHIFT-TOWARDS-END")
691 (inst mtctl amount :sar)
692 (inst shd zero-tn num :variable r)))
698 (define-vop (bignum-length get-header-data)
699 (:translate sb!bignum:%bignum-length)
700 (:policy :fast-safe))
702 (define-vop (bignum-set-length set-header-data)
703 (:translate sb!bignum:%bignum-set-length)
704 (:policy :fast-safe))
706 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
707 (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
709 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
710 (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
712 (define-vop (digit-0-or-plus)
713 (:translate sb!bignum:%digit-0-or-plusp)
715 (:args (digit :scs (unsigned-reg)))
716 (:arg-types unsigned-num)
722 (inst bc :>= not-p digit zero-tn target)))
724 (define-vop (add-w/carry)
725 (:translate sb!bignum:%add-with-carry)
727 (:args (a :scs (unsigned-reg))
728 (b :scs (unsigned-reg))
729 (c :scs (unsigned-reg)))
730 (:arg-types unsigned-num unsigned-num positive-fixnum)
731 (:results (result :scs (unsigned-reg))
732 (carry :scs (unsigned-reg)))
733 (:result-types unsigned-num positive-fixnum)
735 (inst addi -1 c zero-tn)
736 (inst addc a b result)
737 (inst addc zero-tn zero-tn carry)))
739 (define-vop (sub-w/borrow)
740 (:translate sb!bignum:%subtract-with-borrow)
742 (:args (a :scs (unsigned-reg))
743 (b :scs (unsigned-reg))
744 (c :scs (unsigned-reg)))
745 (:arg-types unsigned-num unsigned-num positive-fixnum)
746 (:results (result :scs (unsigned-reg))
747 (borrow :scs (unsigned-reg)))
748 (:result-types unsigned-num positive-fixnum)
750 (inst addi -1 c zero-tn)
751 (inst subb a b result)
752 (inst addc zero-tn zero-tn borrow)))
754 (define-vop (bignum-mult)
755 (:translate sb!bignum:%multiply)
757 (:args (x-arg :scs (unsigned-reg) :target x)
758 (y-arg :scs (unsigned-reg) :target y))
759 (:arg-types unsigned-num unsigned-num)
760 (:temporary (:scs (signed-reg) :from (:argument 0)) x)
761 (:temporary (:scs (signed-reg) :from (:argument 1)) y)
762 (:temporary (:scs (signed-reg)) tmp)
763 (:results (hi :scs (unsigned-reg))
764 (lo :scs (unsigned-reg)))
765 (:result-types unsigned-num unsigned-num)
767 ;; Make sure X is less then Y.
768 (inst comclr x-arg y-arg tmp :<<)
769 (inst xor x-arg y-arg tmp)
770 (inst xor x-arg tmp x)
771 (inst xor y-arg tmp y)
773 ;; Blow out of here if the result is zero.
775 (inst comb := x zero-tn done)
780 (inst comb :ev x zero-tn next-bit)
783 (inst addc hi tmp hi)
786 (inst comb :<> x zero-tn loop)
787 (inst addc tmp tmp tmp)
791 (define-source-transform sb!bignum:%multiply-and-add (x y carry &optional (extra 0))
792 #+nil ;; This would be greate if it worked, but it doesn't.
794 `(multiple-value-call #'sb!bignum:%dual-word-add
795 (sb!bignum:%multiply ,x ,y)
797 `(multiple-value-call #'sb!bignum:%dual-word-add
798 (multiple-value-call #'sb!bignum:%dual-word-add
799 (sb!bignum:%multiply ,x ,y)
802 (with-unique-names (hi lo)
804 `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
805 (sb!bignum::%dual-word-add ,hi ,lo ,carry))
806 `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
809 (sb!bignum::%dual-word-add ,hi ,lo ,carry)
810 (sb!bignum::%dual-word-add ,hi ,lo ,extra))))))
812 (defknown sb!bignum::%dual-word-add
813 (sb!bignum:bignum-element-type sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
814 (values sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
817 (define-vop (dual-word-add)
819 (:translate sb!bignum::%dual-word-add)
820 (:args (hi :scs (unsigned-reg) :to (:result 1))
821 (lo :scs (unsigned-reg))
822 (extra :scs (unsigned-reg)))
823 (:arg-types unsigned-num unsigned-num unsigned-num)
824 (:results (hi-res :scs (unsigned-reg) :from (:result 1))
825 (lo-res :scs (unsigned-reg) :from (:result 0)))
826 (:result-types unsigned-num unsigned-num)
830 (inst add lo extra lo-res)
831 (inst addc hi zero-tn hi-res)))
833 (define-vop (bignum-lognot)
834 (:translate sb!bignum:%lognot)
836 (:args (x :scs (unsigned-reg)))
837 (:arg-types unsigned-num)
838 (:results (r :scs (unsigned-reg)))
839 (:result-types unsigned-num)
841 (inst uaddcm zero-tn x r)))
843 (define-vop (fixnum-to-digit)
844 (:translate sb!bignum:%fixnum-to-digit)
846 (:args (fixnum :scs (signed-reg)))
847 (:arg-types tagged-num)
848 (:results (digit :scs (unsigned-reg)))
849 (:result-types unsigned-num)
851 (move fixnum digit)))
853 (define-vop (bignum-floor)
854 (:translate sb!bignum:%floor)
856 (:args (hi :scs (unsigned-reg) :to (:argument 1))
857 (lo :scs (unsigned-reg) :to (:argument 0))
858 (divisor :scs (unsigned-reg)))
859 (:arg-types unsigned-num unsigned-num unsigned-num)
860 (:temporary (:scs (unsigned-reg) :to (:argument 1)) temp)
861 (:results (quo :scs (unsigned-reg) :from (:argument 0))
862 (rem :scs (unsigned-reg) :from (:argument 1)))
863 (:result-types unsigned-num unsigned-num)
865 (inst sub zero-tn divisor temp)
866 (inst ds zero-tn temp zero-tn)
868 (inst ds hi divisor rem)
869 (inst addc quo quo quo)
871 (inst ds rem divisor rem)
872 (inst addc quo quo quo))
873 (inst comclr rem zero-tn zero-tn :>=)
874 (inst add divisor rem rem)))
876 (define-vop (signify-digit)
877 (:translate sb!bignum:%fixnum-digit-with-correct-sign)
879 (:args (digit :scs (unsigned-reg) :target res))
880 (:arg-types unsigned-num)
881 (:results (res :scs (signed-reg)))
882 (:result-types signed-num)
886 (define-vop (digit-lshr)
887 (:translate sb!bignum:%digit-logical-shift-right)
889 (:args (digit :scs (unsigned-reg))
890 (count :scs (unsigned-reg)))
891 (:arg-types unsigned-num positive-fixnum)
892 (:results (result :scs (unsigned-reg)))
893 (:result-types unsigned-num)
895 (inst mtctl count :sar)
896 (inst shd zero-tn digit :variable result)))
898 (define-vop (digit-ashr digit-lshr)
899 (:translate sb!bignum:%ashr)
900 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
902 (inst extrs digit 0 1 temp)
903 (inst mtctl count :sar)
904 (inst shd temp digit :variable result)))
906 (define-vop (digit-ashl digit-ashr)
907 (:translate sb!bignum:%ashl)
909 (inst subi 31 count temp)
910 (inst mtctl temp :sar)
911 (inst zdep digit :variable 32 result)))
914 ;;;; Static functions.
916 (define-static-fun two-arg-gcd (x y) :translate gcd)
917 (define-static-fun two-arg-lcm (x y) :translate lcm)
919 (define-static-fun two-arg-* (x y) :translate *)
920 (define-static-fun two-arg-/ (x y) :translate /)
922 (define-static-fun %negate (x) :translate %negate)
924 (define-static-fun two-arg-and (x y) :translate logand)
925 (define-static-fun two-arg-ior (x y) :translate logior)
926 (define-static-fun two-arg-xor (x y) :translate logxor)