Skip to content
Snippets Groups Projects
arith.lisp 25.9 KiB
Newer Older
wlott's avatar
wlott committed
;;; -*- Package: HPPA -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/arith.lisp,v 1.2 1992/08/04 14:14:12 wlott Exp $")
wlott's avatar
wlott committed
;;;
;;; **********************************************************************
;;;
;;; This file contains the VM definition arithmetic VOPs for the HP-PA.
;;;
;;; Written by William Lott.
;;; 

(in-package "HPPA")



;;;; Unary operations.

(define-vop (fixnum-unop)
  (:args (x :scs (any-reg)))
  (:results (res :scs (any-reg)))
  (:note "inline fixnum arithmetic")
  (:arg-types tagged-num)
  (:result-types tagged-num)
  (:policy :fast-safe))

(define-vop (signed-unop)
  (:args (x :scs (signed-reg)))
  (:results (res :scs (signed-reg)))
  (:note "inline (signed-byte 32) arithmetic")
  (:arg-types signed-num)
  (:result-types signed-num)
  (:policy :fast-safe))

(define-vop (fast-negate/fixnum fixnum-unop)
  (:translate %negate)
  (:generator 1
    (inst sub zero-tn x res)))

(define-vop (fast-negate/signed signed-unop)
  (:translate %negate)
  (:generator 2
    (inst sub zero-tn x res)))

(define-vop (fast-lognot/fixnum fixnum-unop)
  (:temporary (:scs (any-reg) :type fixnum :to (:result 0))
	      temp)
  (:translate lognot)
  (:generator 2
    (inst li (fixnum -1) temp)
    (inst xor x temp res)))

(define-vop (fast-lognot/signed signed-unop)
  (:translate lognot)
  (:generator 1
    (inst uaddcm zero-tn x res)))



;;;; Binary fixnum operations.

;;; Assume that any constant operand is the second arg...

(define-vop (fast-fixnum-binop)
  (:args (x :target r :scs (any-reg))
	 (y :target r :scs (any-reg)))
  (:arg-types tagged-num tagged-num)
  (:results (r :scs (any-reg)))
  (:result-types tagged-num)
  (:note "inline fixnum arithmetic")
  (:effects)
  (:affected)
  (:policy :fast-safe))

(define-vop (fast-unsigned-binop)
  (:args (x :target r :scs (unsigned-reg))
	 (y :target r :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num)
  (:results (r :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:note "inline (unsigned-byte 32) arithmetic")
  (:effects)
  (:affected)
  (:policy :fast-safe))

(define-vop (fast-signed-binop)
  (:args (x :target r :scs (signed-reg))
	 (y :target r :scs (signed-reg)))
  (:arg-types signed-num signed-num)
  (:results (r :scs (signed-reg)))
  (:result-types signed-num)
  (:note "inline (signed-byte 32) arithmetic")
  (:effects)
  (:affected)
  (:policy :fast-safe))

(defmacro define-binop (translate cost untagged-cost op)
  `(progn
     (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
		  fast-fixnum-binop)
       (:args (x :target r :scs (any-reg))
	      (y :target r :scs (any-reg)))
       (:translate ,translate)
       (:generator ,cost
	 (inst ,op x y r)))
     (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
		  fast-signed-binop)
       (:args (x :target r :scs (signed-reg))
	      (y :target r :scs (signed-reg)))
       (:translate ,translate)
       (:generator ,untagged-cost
	 (inst ,op x y r)))
     (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
		  fast-unsigned-binop)
       (:args (x :target r :scs (unsigned-reg))
	      (y :target r :scs (unsigned-reg)))
       (:translate ,translate)
       (:generator ,untagged-cost
	 (inst ,op x y r)))))

(define-binop + 2 6 add)
(define-binop - 2 6 sub)
(define-binop logior 1 2 or)
(define-binop logand 1 2 and)
(define-binop logandc2 1 2 andcm)
(define-binop logxor 1 2 xor)

(define-vop (fast-fixnum-c-binop fast-fixnum-binop)
  (:args (x :target r :scs (any-reg)))
  (:info y)
  (:arg-types tagged-num (:constant integer)))

(define-vop (fast-signed-c-binop fast-signed-binop)
  (:args (x :target r :scs (signed-reg)))
  (:info y)
  (:arg-types tagged-num (:constant integer)))

(define-vop (fast-unsigned-c-binop fast-unsigned-binop)
  (:args (x :target r :scs (unsigned-reg)))
  (:info y)
  (:arg-types tagged-num (:constant integer)))

(defmacro define-c-binop (translate cost untagged-cost tagged-type
				    untagged-type inst)
  `(progn
     (define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
		  fast-fixnum-c-binop)
       (:arg-types tagged-num (:constant ,tagged-type))
       (:translate ,translate)
       (:generator ,cost
	 (let ((y (fixnum y)))
	   ,inst)))
     (define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
		  fast-signed-c-binop)
       (:arg-types signed-num (:constant ,untagged-type))
       (:translate ,translate)
       (:generator ,untagged-cost
	 ,inst))
     (define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED=>UNSIGNED")
		  fast-unsigned-c-binop)
       (:arg-types unsigned-num (:constant ,untagged-type))
       (:translate ,translate)
       (:generator ,untagged-cost
	 ,inst))))

(define-c-binop + 1 3 (signed-byte 9) (signed-byte 11)
  (inst addi y x r))
(define-c-binop - 1 3
  (integer #.(- (1- (ash 1 9))) #.(ash 1 9))
  (integer #.(- (1- (ash 1 11))) #.(ash 1 11))
  (inst addi (- y) x r))

;;; Special case fixnum + and - that trap on overflow.  Useful when we don't
;;; know that the result is going to be a fixnum.

(define-vop (fast-+/fixnum fast-+/fixnum=>fixnum)
  (:results (r :scs (any-reg descriptor-reg)))
  (:result-types (:or signed-num unsigned-num))
  (:note nil)
  (:generator 4
    (inst addo x y r)))

(define-vop (fast-+-c/fixnum fast-+-c/fixnum=>fixnum)
  (:results (r :scs (any-reg descriptor-reg)))
  (:result-types (:or signed-num unsigned-num))
  (:note nil)
  (:generator 3
    (inst addio (fixnum y) x r)))

(define-vop (fast--/fixnum fast--/fixnum=>fixnum)
  (:results (r :scs (any-reg descriptor-reg)))
  (:result-types (:or signed-num unsigned-num))
  (:note nil)
  (:generator 4
    (inst subo x y r)))

(define-vop (fast---c/fixnum fast---c/fixnum=>fixnum)
  (:results (r :scs (any-reg descriptor-reg)))
  (:result-types (:or signed-num unsigned-num))
  (:note nil)
  (:generator 3
    (inst addio (- (fixnum y)) x r)))

;;; Shifting

(define-vop (fast-ash)
  (:policy :fast-safe)
  (:translate ash)
  (:note "inline word ASH")
  (:args (number :scs (signed-reg unsigned-reg))
	 (count :scs (signed-reg)))
  (:arg-types (:or signed-num unsigned-num) tagged-num)
  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
  (:results (result :scs (signed-reg unsigned-reg)))
  (:result-types (:or signed-num unsigned-num))
  (:generator 8
    (inst comb :>= count zero-tn positive :nullify t)
    (inst sub zero-tn count temp)
    (inst comiclr 31 temp zero-tn :>=)
    (inst li 31 temp)
    (inst mtctl temp :sar)
    (inst extrs number 0 1 temp)
    (inst b done)
    (inst shd temp number :variable result)
    POSITIVE
    (inst subi 31 count temp)
    (inst mtctl temp :sar)
    (inst zdep number :variable 32 result)
    DONE))

(define-vop (fast-ash-c)
  (:policy :fast-safe)
  (:translate ash)
  (:note nil)
  (:args (number :scs (signed-reg unsigned-reg)))
  (:info count)
  (:arg-types (:or signed-num unsigned-num) (:constant integer))
  (:results (result :scs (signed-reg unsigned-reg)))
  (:result-types (:or signed-num unsigned-num))
  (:generator 1
    (cond ((< count 0)
	   ;; It is a right shift.
	   (sc-case number
	     (signed-reg (inst sra number (min (- count) 31) result))
	     (unsigned-reg (inst srl number (min (- count) 31) result))))
wlott's avatar
wlott committed
252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853
	  ((> count 0)
	   ;; It is a left shift.
	   (inst sll number (min count 31) result))
	  (t
	   ;; Count=0?  Shouldn't happen, but it's easy:
	   (move number result)))))


(define-vop (signed-byte-32-len)
  (:translate integer-length)
  (:note "inline (signed-byte 32) integer-length")
  (:policy :fast-safe)
  (:args (arg :scs (signed-reg) :target shift))
  (:arg-types signed-num)
  (:results (res :scs (any-reg)))
  (:result-types positive-fixnum)
  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
  (:generator 30
    (inst move arg shift :>=)
    (inst uaddcm zero-tn shift shift)
    (inst comb := shift zero-tn done)
    (inst li 0 res)
    LOOP
    (inst srl shift 1 shift)
    (inst comb :<> shift zero-tn loop)
    (inst addi (fixnum 1) res res)
    DONE))

(define-vop (unsigned-byte-32-count)
  (:translate logcount)
  (:note "inline (unsigned-byte 32) logcount")
  (:policy :fast-safe)
  (:args (arg :scs (unsigned-reg) :target num))
  (:arg-types unsigned-num)
  (:results (res :scs (unsigned-reg)))
  (:result-types positive-fixnum)
  (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0)
		    :target res) num)
  (:temporary (:scs (non-descriptor-reg)) mask temp)
  (:generator 30
    (inst li #x55555555 mask)
    (inst srl arg 1 temp)
    (inst and arg mask num)
    (inst and temp mask temp)
    (inst add num temp num)
    (inst li #x33333333 mask)
    (inst srl num 2 temp)
    (inst and num mask num)
    (inst and temp mask temp)
    (inst add num temp num)
    (inst li #x0f0f0f0f mask)
    (inst srl num 4 temp)
    (inst and num mask num)
    (inst and temp mask temp)
    (inst add num temp num)
    (inst li #x00ff00ff mask)
    (inst srl num 8 temp)
    (inst and num mask num)
    (inst and temp mask temp)
    (inst add num temp num)
    (inst li #x0000ffff mask)
    (inst srl num 16 temp)
    (inst and num mask num)
    (inst and temp mask temp)
    (inst add num temp res)))

;;; Multiply and Divide.

(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
  (:args (x :scs (any-reg) :target x-pass)
	 (y :scs (any-reg) :target y-pass))
  (:temporary (:sc signed-reg :offset nl0-offset
		   :from (:argument 0) :to (:result 0)) x-pass)
  (:temporary (:sc signed-reg :offset nl1-offset
		   :from (:argument 1) :to (:result 0)) y-pass)
  (:temporary (:sc signed-reg :offset nl2-offset :target r
		   :from (:argument 1) :to (:result 0)) res-pass)
  (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp)
  (:temporary (:sc signed-reg :offset nl4-offset
		   :from (:argument 1) :to (:result 0)) sign)
  (:temporary (:sc interior-reg :offset lip-offset) lip)
  (:ignore lip sign)
  (:translate *)
  (:generator 30
    (unless (location= y y-pass)
      (inst sra x 2 x-pass))
    (let ((fixup (make-fixup 'multiply :assembly-routine)))
      (inst ldil fixup tmp)
      (inst ble fixup lisp-heap-space tmp))
    (if (location= y y-pass)
	(inst sra x 2 x-pass)
	(inst move y y-pass))
    (move res-pass r)))

(define-vop (fast-*/signed=>signed fast-signed-binop)
  (:translate *)
  (:args (x :scs (signed-reg) :target x-pass)
	 (y :scs (signed-reg) :target y-pass))
  (:temporary (:sc signed-reg :offset nl0-offset
		   :from (:argument 0) :to (:result 0)) x-pass)
  (:temporary (:sc signed-reg :offset nl1-offset
		   :from (:argument 1) :to (:result 0)) y-pass)
  (:temporary (:sc signed-reg :offset nl2-offset :target r
		   :from (:argument 1) :to (:result 0)) res-pass)
  (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp)
  (:temporary (:sc signed-reg :offset nl4-offset
		   :from (:argument 1) :to (:result 0)) sign)
  (:temporary (:sc interior-reg :offset lip-offset) lip)
  (:ignore lip sign)
  (:translate *)
  (:generator 31
    (let ((fixup (make-fixup 'multiply :assembly-routine)))
      (move x x-pass)
      (move y y-pass)
      (inst ldil fixup tmp)
      (inst ble fixup lisp-heap-space tmp :nullify t)
      (inst nop)
      (move res-pass r))))

(define-vop (fast-truncate/fixnum fast-fixnum-binop)
  (:translate truncate)
  (:args (x :scs (any-reg) :target x-pass)
	 (y :scs (any-reg) :target y-pass))
  (:temporary (:sc signed-reg :offset nl0-offset
		   :from (:argument 0) :to (:result 0)) x-pass)
  (:temporary (:sc signed-reg :offset nl1-offset
		   :from (:argument 1) :to (:result 0)) y-pass)
  (:temporary (:sc signed-reg :offset nl2-offset :target q
		   :from (:argument 1) :to (:result 0)) q-pass)
  (:temporary (:sc signed-reg :offset nl3-offset :target r
		   :from (:argument 1) :to (:result 1)) r-pass)
  (:results (q :scs (signed-reg))
	    (r :scs (any-reg)))
  (:result-types tagged-num tagged-num)
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 30
    (let ((zero (generate-error-code vop division-by-zero-error x y)))
      (inst bc := nil y zero-tn zero))
    (move x x-pass)
    (move y y-pass)
    (let ((fixup (make-fixup 'truncate :assembly-routine)))
      (inst ldil fixup q-pass)
      (inst ble fixup lisp-heap-space q-pass :nullify t))
    (inst nop)
    (move q-pass q)
    (move r-pass r)))

(define-vop (fast-truncate/signed fast-signed-binop)
  (:translate truncate)
  (:args (x :scs (signed-reg) :target x-pass)
	 (y :scs (signed-reg) :target y-pass))
  (:temporary (:sc signed-reg :offset nl0-offset
		   :from (:argument 0) :to (:result 0)) x-pass)
  (:temporary (:sc signed-reg :offset nl1-offset
		   :from (:argument 1) :to (:result 0)) y-pass)
  (:temporary (:sc signed-reg :offset nl2-offset :target q
		   :from (:argument 1) :to (:result 0)) q-pass)
  (:temporary (:sc signed-reg :offset nl3-offset :target r
		   :from (:argument 1) :to (:result 1)) r-pass)
  (:results (q :scs (signed-reg))
	    (r :scs (signed-reg)))
  (:result-types signed-num signed-num)
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 35
    (let ((zero (generate-error-code vop division-by-zero-error x y)))
      (inst bc := nil y zero-tn zero))
    (move x x-pass)
    (move y y-pass)
    (let ((fixup (make-fixup 'truncate :assembly-routine)))
      (inst ldil fixup q-pass)
      (inst ble fixup lisp-heap-space q-pass :nullify t))
    (inst nop)
    (move q-pass q)
    (move r-pass r)))


;;;; Binary conditional VOPs:

(define-vop (fast-conditional)
  (:conditional)
  (:info target not-p)
  (:effects)
  (:affected)
  (:policy :fast-safe))

(define-vop (fast-conditional/fixnum fast-conditional)
  (:args (x :scs (any-reg))
	 (y :scs (any-reg)))
  (:arg-types tagged-num tagged-num)
  (:note "inline fixnum comparison"))

(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
  (:args (x :scs (any-reg)))
  (:arg-types tagged-num (:constant (signed-byte 9)))
  (:info target not-p y))

(define-vop (fast-conditional/signed fast-conditional)
  (:args (x :scs (signed-reg))
	 (y :scs (signed-reg)))
  (:arg-types signed-num signed-num)
  (:note "inline (signed-byte 32) comparison"))

(define-vop (fast-conditional-c/signed fast-conditional/signed)
  (:args (x :scs (signed-reg)))
  (:arg-types signed-num (:constant (signed-byte 11)))
  (:info target not-p y))

(define-vop (fast-conditional/unsigned fast-conditional)
  (:args (x :scs (unsigned-reg))
	 (y :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num)
  (:note "inline (unsigned-byte 32) comparison"))

(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
  (:args (x :scs (unsigned-reg)))
  (:arg-types unsigned-num (:constant (signed-byte 11)))
  (:info target not-p y))


(defmacro define-conditional-vop (translate signed-cond unsigned-cond)
  `(progn
     ,@(mapcar #'(lambda (suffix cost signed imm)
		   (unless (and (member suffix '(/fixnum -c/fixnum))
				(eq translate 'eql))
		     `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
						    translate suffix))
				   ,(intern
				     (format nil "~:@(FAST-CONDITIONAL~A~)"
					     suffix)))
			(:translate ,translate)
			(:generator ,cost
			  (inst ,(if imm 'bci 'bc)
				,(if signed signed-cond unsigned-cond)
				not-p
				,(if (eq suffix '-c/fixnum)
				     '(fixnum y)
				     'y)
				x
				target)))))
	       '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
	       '(3 2 5 4 5 4)
	       '(t t t t nil nil)
	       '(nil t nil t nil t))))

;; We switch < and > because the immediate has to come first.

(define-conditional-vop < :> :>>)
(define-conditional-vop > :< :<<)

;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
;;; known fixnum.
;;;
(define-conditional-vop eql := :=)

;;; These versions specify a fixnum restriction on their first arg.  We have
;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
;;; the first arg and a higher cost.  The reason for doing this is to prevent
;;; fixnum specific operations from being used on word integers, spuriously
;;; consing the argument.
;;;
(define-vop (fast-eql/fixnum fast-conditional)
  (:args (x :scs (any-reg descriptor-reg))
	 (y :scs (any-reg)))
  (:arg-types tagged-num tagged-num)
  (:note "inline fixnum comparison")
  (:translate eql)
  (:generator 3
    (inst bc := not-p x y target)))
;;;
(define-vop (generic-eql/fixnum fast-eql/fixnum)
  (:arg-types * tagged-num)
  (:variant-cost 7))

(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
  (:args (x :scs (any-reg descriptor-reg)))
  (:arg-types tagged-num (:constant (signed-byte 9)))
  (:info target not-p y)
  (:translate eql)
  (:generator 2
    (inst bci := not-p (fixnum y) x target)))
;;;
(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
  (:arg-types * (:constant (signed-byte 14)))
  (:variant-cost 6))
  

;;;; 32-bit logical operations

(define-vop (32bit-logical)
  (:args (x :scs (unsigned-reg))
	 (y :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num)
  (:results (r :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:policy :fast-safe))

(define-vop (32bit-logical-not 32bit-logical)
  (:translate 32bit-logical-not)
  (:args (x :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:generator 1
    (inst uaddcm zero-tn x r)))

(define-vop (32bit-logical-and 32bit-logical)
  (:translate 32bit-logical-and)
  (:generator 1
    (inst and x y r)))

(deftransform 32bit-logical-nand ((x y) (* *))
  '(32bit-logical-not (32bit-logical-and x y)))

(define-vop (32bit-logical-or 32bit-logical)
  (:translate 32bit-logical-or)
  (:generator 1
    (inst or x y r)))

(deftransform 32bit-logical-nor ((x y) (* *))
  '(32bit-logical-not (32bit-logical-or x y)))

(define-vop (32bit-logical-xor 32bit-logical)
  (:translate 32bit-logical-xor)
  (:generator 1
    (inst xor x y r)))

(deftransform 32bit-logical-eqv ((x y) (* *))
  '(32bit-logical-not (32bit-logical-xor x y)))

(deftransform 32bit-logical-andc1 ((x y) (* *))
  '(32bit-logical-and (32bit-logical-not x) y))

(define-vop (32bit-logical-andc2 32bit-logical)
  (:translate 32bit-logical-andc2)
  (:generator 1
    (inst andcm x y r)))

(deftransform 32bit-logical-orc1 ((x y) (* *))
  '(32bit-logical-or (32bit-logical-not x) y))

(deftransform 32bit-logical-orc2 ((x y) (* *))
  '(32bit-logical-or x (32bit-logical-not y)))


(define-vop (shift-towards-someplace)
  (:policy :fast-safe)
  (:args (num :scs (unsigned-reg))
	 (amount :scs (signed-reg)))
  (:arg-types unsigned-num tagged-num)
  (:results (r :scs (unsigned-reg)))
  (:result-types unsigned-num))

(define-vop (shift-towards-start shift-towards-someplace)
  (:translate shift-towards-start)
  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
  (:note "SHIFT-TOWARDS-START")
  (:generator 1
    (inst subi 31 amount temp)
    (inst mtctl temp :sar)
    (inst zdep num :variable 32 r)))

(define-vop (shift-towards-end shift-towards-someplace)
  (:translate shift-towards-end)
  (:note "SHIFT-TOWARDS-END")
  (:generator 1
    (inst mtctl amount :sar)
    (inst shd zero-tn num :variable r)))



;;;; Bignum stuff.

(define-vop (bignum-length get-header-data)
  (:translate bignum::%bignum-length)
  (:policy :fast-safe))

(define-vop (bignum-set-length set-header-data)
  (:translate bignum::%bignum-set-length)
  (:policy :fast-safe))

(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type
  (unsigned-reg) unsigned-num bignum::%bignum-ref)

(define-full-setter bignum-set * bignum-digits-offset other-pointer-type
  (unsigned-reg) unsigned-num bignum::%bignum-set)

(define-vop (digit-0-or-plus)
  (:translate bignum::%digit-0-or-plusp)
  (:policy :fast-safe)
  (:args (digit :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:conditional)
  (:info target not-p)
  (:effects)
  (:affected)
  (:generator 1
    (inst bc :>= not-p digit zero-tn target)))

(define-vop (add-w/carry)
  (:translate bignum::%add-with-carry)
  (:policy :fast-safe)
  (:args (a :scs (unsigned-reg))
	 (b :scs (unsigned-reg))
	 (c :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num positive-fixnum)
  (:results (result :scs (unsigned-reg))
	    (carry :scs (unsigned-reg)))
  (:result-types unsigned-num positive-fixnum)
  (:generator 3
    (inst addi -1 c zero-tn)
    (inst addc a b result)
    (inst addc zero-tn zero-tn carry)))

(define-vop (sub-w/borrow)
  (:translate bignum::%subtract-with-borrow)
  (:policy :fast-safe)
  (:args (a :scs (unsigned-reg))
	 (b :scs (unsigned-reg))
	 (c :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num positive-fixnum)
  (:results (result :scs (unsigned-reg))
	    (borrow :scs (unsigned-reg)))
  (:result-types unsigned-num positive-fixnum)
  (:generator 4
    (inst addi -1 c zero-tn)
    (inst subb a b result)
    (inst addc zero-tn zero-tn borrow)))

(define-vop (bignum-mult)
  (:translate bignum::%multiply)
  (:policy :fast-safe)
  (:args (x-arg :scs (unsigned-reg) :target x)
	 (y-arg :scs (unsigned-reg) :target y))
  (:arg-types unsigned-num unsigned-num)
  (:temporary (:scs (signed-reg) :from (:argument 0)) x)
  (:temporary (:scs (signed-reg) :from (:argument 1)) y)
  (:temporary (:scs (signed-reg)) tmp)
  (:results (hi :scs (unsigned-reg))
	    (lo :scs (unsigned-reg)))
  (:result-types unsigned-num unsigned-num)
  (:generator 3
    ;; Make sure X is less then Y.
    (inst comclr x-arg y-arg tmp :<<)
    (inst xor x-arg y-arg tmp)
    (inst xor x-arg tmp x)
    (inst xor y-arg tmp y)

    ;; Blow out of here if the result is zero.
    (inst li 0 hi)
    (inst comb := x zero-tn done)
    (inst li 0 lo)
    (inst li 0 tmp)

    LOOP
    (inst comb :ev x zero-tn next-bit)
    (inst srl x 1 x)
    (inst add lo y lo)
    (inst addc hi tmp hi)
    NEXT-BIT
    (inst add y y y)
    (inst comb :<> x zero-tn loop)
    (inst addc tmp tmp tmp)

    DONE))

(def-source-transform bignum:%multiply-and-add (x y carry &optional (extra 0))
  #+nil ;; This would be greate if it worked, but it doesn't.
  (if (eql extra 0)
      `(multiple-value-call #'bignum::%dual-word-add
	 (bignum:%multiply ,x ,y)
	 (values ,carry))
      `(multiple-value-call #'bignum::%dual-word-add
	 (multiple-value-call #'bignum::%dual-word-add
	   (bignum:%multiply ,x ,y)
	   (values ,carry))
	 (values ,extra)))
  (let ((hi (gensym "HI-"))
	(lo (gensym "LO-")))
    (if (eql extra 0)
	`(multiple-value-bind (,hi ,lo) (bignum:%multiply ,x ,y)
	   (bignum::%dual-word-add ,hi ,lo ,carry))
	`(multiple-value-bind (,hi ,lo) (bignum:%multiply ,x ,y)
	   (multiple-value-bind
	       (,hi ,lo)
	       (bignum::%dual-word-add ,hi ,lo ,carry)
	     (bignum::%dual-word-add ,hi ,lo ,extra))))))

(defknown bignum::%dual-word-add
	  (bignum-element-type bignum-element-type bignum-element-type)
  (values bignum-element-type bignum-element-type)
  (flushable movable))

(define-vop (dual-word-add)
  (:policy :fast-safe)
  (:translate bignum::%dual-word-add)
  (:args (hi :scs (unsigned-reg) :to (:result 1))
	 (lo :scs (unsigned-reg))
	 (extra :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num unsigned-num)
  (:results (hi-res :scs (unsigned-reg) :from (:result 1))
	    (lo-res :scs (unsigned-reg) :from (:result 0)))
  (:result-types unsigned-num unsigned-num)
  (:affected)
  (:effects)
  (:generator 3
    (inst add lo extra lo-res)
    (inst addc hi zero-tn hi-res)))

(define-vop (bignum-lognot)
  (:translate bignum::%lognot)
  (:policy :fast-safe)
  (:args (x :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:results (r :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:generator 1
    (inst uaddcm zero-tn x r)))

(define-vop (fixnum-to-digit)
  (:translate bignum::%fixnum-to-digit)
  (:policy :fast-safe)
  (:args (fixnum :scs (signed-reg)))
  (:arg-types tagged-num)
  (:results (digit :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:generator 1
    (move fixnum digit)))

(define-vop (bignum-floor)
  (:translate bignum::%floor)
  (:policy :fast-safe)
  (:args (hi :scs (unsigned-reg) :to (:argument 1))
	 (lo :scs (unsigned-reg) :to (:argument 0))
	 (divisor :scs (unsigned-reg)))
  (:arg-types unsigned-num unsigned-num unsigned-num)
  (:temporary (:scs (unsigned-reg) :to (:argument 1)) temp)
  (:results (quo :scs (unsigned-reg) :from (:argument 0))
	    (rem :scs (unsigned-reg) :from (:argument 1)))
  (:result-types unsigned-num unsigned-num)
  (:generator 65
    (inst sub zero-tn divisor temp)
    (inst ds zero-tn temp zero-tn)
    (inst add lo lo quo)
    (inst ds hi divisor rem)
    (inst addc quo quo quo)
    (dotimes (i 31)
      (inst ds rem divisor rem)
      (inst addc quo quo quo))
    (inst comclr rem zero-tn zero-tn :>=)
    (inst add divisor rem rem)))

(define-vop (signify-digit)
  (:translate bignum::%fixnum-digit-with-correct-sign)
  (:policy :fast-safe)
  (:args (digit :scs (unsigned-reg) :target res))
  (:arg-types unsigned-num)
  (:results (res :scs (signed-reg)))
  (:result-types signed-num)
  (:generator 1
    (move digit res)))

(define-vop (digit-lshr)
  (:translate bignum::%digit-logical-shift-right)
  (:policy :fast-safe)
  (:args (digit :scs (unsigned-reg))
	 (count :scs (unsigned-reg)))
  (:arg-types unsigned-num positive-fixnum)
  (:results (result :scs (unsigned-reg)))
  (:result-types unsigned-num)
  (:generator 2
    (inst mtctl count :sar)
    (inst shd zero-tn digit :variable result)))

(define-vop (digit-ashr digit-lshr)
  (:translate bignum::%ashr)
  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
  (:generator 1
    (inst extrs digit 0 1 temp)
    (inst mtctl count :sar)
    (inst shd temp digit :variable result)))

(define-vop (digit-ashl digit-ashr)
  (:translate bignum::%ashl)
  (:generator 1
    (inst subi 31 count temp)
    (inst mtctl temp :sar)
    (inst zdep digit :variable 32 result)))


;;;; Static functions.

(define-static-function two-arg-gcd (x y) :translate gcd)
(define-static-function two-arg-lcm (x y) :translate lcm)

(define-static-function two-arg-* (x y) :translate *)
(define-static-function two-arg-/ (x y) :translate /)

(define-static-function %negate (x) :translate %negate)

(define-static-function two-arg-and (x y) :translate logand)
(define-static-function two-arg-ior (x y) :translate logior)
(define-static-function two-arg-xor (x y) :translate logxor)