src/compiler/hppa/arith.lisp

   1 ;;;; the VM definition arithmetic VOPs for HPPA
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   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.
  11
  12 (in-package "SB!VM")
  13 \f
  14 ;;;; Unary operations.
  15
  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)
  22   (:policy :fast-safe))
  23
  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)
  30   (:policy :fast-safe))
  31
  32 (define-vop (fast-negate/fixnum fixnum-unop)
  33   (:translate %negate)
  34   (:generator 1
  35     (inst sub zero-tn x res)))
  36
  37 (define-vop (fast-negate/signed signed-unop)
  38   (:translate %negate)
  39   (:generator 2
  40     (inst sub zero-tn x res)))
  41
  42 (define-vop (fast-lognot/fixnum fixnum-unop)
  43   (:temporary (:scs (any-reg) :type fixnum :to (:result 0))
  44               temp)
  45   (:translate lognot)
  46   (:generator 2
  47     (inst li (fixnumize -1) temp)
  48     (inst xor x temp res)))
  49
  50 (define-vop (fast-lognot/signed signed-unop)
  51   (:translate lognot)
  52   (:generator 1
  53     (inst uaddcm zero-tn x res)))
  54 \f
  55 ;;;; Binary fixnum operations.
  56
  57 ;;; Assume that any constant operand is the second arg...
  58
  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")
  66   (:effects)
  67   (:affected)
  68   (:policy :fast-safe))
  69
  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")
  77   (:effects)
  78   (:affected)
  79   (:policy :fast-safe))
  80
  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")
  88   (:effects)
  89   (:affected)
  90   (:policy :fast-safe))
  91
  92 (defmacro define-binop (translate cost untagged-cost op &optional arg-swap)
  93   `(progn
  94      (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
  95                   fast-fixnum-binop)
  96        (:args (x :target r :scs (any-reg))
  97               (y :target r :scs (any-reg)))
  98        (:translate ,translate)
  99        (:generator ,cost
 100          ,(if arg-swap
 101               `(inst ,op y x r)
 102               `(inst ,op x y r))))
 103      (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
 104                   fast-signed-binop)
 105        (:args (x :target r :scs (signed-reg))
 106               (y :target r :scs (signed-reg)))
 107        (:translate ,translate)
 108        (:generator ,untagged-cost
 109          ,(if arg-swap
 110               `(inst ,op y x r)
 111               `(inst ,op x y r))))
 112      (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
 113                   fast-unsigned-binop)
 114        (:args (x :target r :scs (unsigned-reg))
 115               (y :target r :scs (unsigned-reg)))
 116        (:translate ,translate)
 117        (:generator ,untagged-cost
 118          ,(if arg-swap
 119               `(inst ,op y x r)
 120               `(inst ,op x y r))))))
 121
 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)
 129
 130 (define-vop (fast-fixnum-c-binop fast-fixnum-binop)
 131   (:args (x :target r :scs (any-reg)))
 132   (:info y)
 133   (:arg-types tagged-num (:constant integer)))
 134
 135 (define-vop (fast-signed-c-binop fast-signed-binop)
 136   (:args (x :target r :scs (signed-reg)))
 137   (:info y)
 138   (:arg-types tagged-num (:constant integer)))
 139
 140 (define-vop (fast-unsigned-c-binop fast-unsigned-binop)
 141   (:args (x :target r :scs (unsigned-reg)))
 142   (:info y)
 143   (:arg-types tagged-num (:constant integer)))
 144
 145 (defmacro define-c-binop (translate cost untagged-cost tagged-type
 146                                     untagged-type inst)
 147   `(progn
 148      (define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
 149                   fast-fixnum-c-binop)
 150        (:arg-types tagged-num (:constant ,tagged-type))
 151        (:translate ,translate)
 152        (:generator ,cost
 153          (let ((y (fixnumize y)))
 154            ,inst)))
 155      (define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
 156                   fast-signed-c-binop)
 157        (:arg-types signed-num (:constant ,untagged-type))
 158        (:translate ,translate)
 159        (:generator ,untagged-cost
 160          ,inst))
 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
 166          ,inst))))
 167
 168 (define-c-binop + 1 3 (signed-byte 9) (signed-byte 11)
 169   (inst addi y x r))
 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))
 174
 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.
 177
 178 (define-vop (fast-+/fixnum fast-+/fixnum=>fixnum)
 179   (:results (r :scs (any-reg descriptor-reg)))
 180   (:result-types (:or signed-num unsigned-num))
 181   (:note nil)
 182   (:generator 4
 183     (inst addo x y r)))
 184
 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))
 188   (:note nil)
 189   (:generator 3
 190     (inst addio (fixnumize y) x r)))
 191
 192 (define-vop (fast--/fixnum fast--/fixnum=>fixnum)
 193   (:results (r :scs (any-reg descriptor-reg)))
 194   (:result-types (:or signed-num unsigned-num))
 195   (:note nil)
 196   (:generator 4
 197     (inst subo x y r)))
 198
 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))
 202   (:note nil)
 203   (:generator 3
 204     (inst addio (- (fixnumize y)) x r)))
 205
 206 ;;; Shifting
 207
 208 (define-vop (fast-ash/unsigned=>unsigned)
 209   (:policy :fast-safe)
 210   (:translate ash)
 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)
 218   (:generator 8
 219     (inst comb :>= count zero-tn positive :nullify t)
 220     (inst sub zero-tn count temp)
 221     (inst comiclr 31 temp zero-tn :>=)
 222     (inst li 31 temp)
 223     (inst mtctl temp :sar)
 224     (inst extrs number 0 1 temp)
 225     (inst b done)
 226     (inst shd temp number :variable result)
 227     POSITIVE
 228     (inst subi 31 count temp)
 229     (inst mtctl temp :sar)
 230     (inst zdep number :variable 32 result)
 231     DONE))
 232
 233 (define-vop (fast-ash/signed=>signed)
 234   (:policy :fast-safe)
 235   (:translate ash)
 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)
 243   (:generator 8
 244     (inst comb :>= count zero-tn positive :nullify t)
 245     (inst sub zero-tn count temp)
 246     (inst comiclr 31 temp zero-tn :>=)
 247     (inst li 31 temp)
 248     (inst mtctl temp :sar)
 249     (inst extrs number 0 1 temp)
 250     (inst b done)
 251     (inst shd temp number :variable result)
 252     POSITIVE
 253     (inst subi 31 count temp)
 254     (inst mtctl temp :sar)
 255     (inst zdep number :variable 32 result)
 256     DONE))
 257
 258 (define-vop (fast-ash-c/unsigned=>unsigned)
 259   (:policy :fast-safe)
 260   (:translate ash)
 261   (:note nil)
 262   (:args (number :scs (unsigned-reg)))
 263   (:info count)
 264   (:arg-types unsigned-num (:constant integer))
 265   (:results (result :scs (unsigned-reg)))
 266   (:result-types unsigned-num)
 267   (:generator 1
 268     (cond ((< count 0)
 269            ;; It is a right shift.
 270            (inst srl number (min (- count) 31) result))
 271           ((> count 0)
 272            ;; It is a left shift.
 273            (inst sll number (min count 31) result))
 274           (t
 275            ;; Count=0?  Shouldn't happen, but it's easy:
 276            (move number result)))))
 277
 278 (define-vop (fast-ash-c/signed=>signed)
 279   (:policy :fast-safe)
 280   (:translate ash)
 281   (:note nil)
 282   (:args (number :scs (signed-reg)))
 283   (:info count)
 284   (:arg-types signed-num (:constant integer))
 285   (:results (result :scs (signed-reg)))
 286   (:result-types signed-num)
 287   (:generator 1
 288     (cond ((< count 0)
 289            ;; It is a right shift.
 290            (inst sra number (min (- count) 31) result))
 291           ((> count 0)
 292            ;; It is a left shift.
 293            (inst sll number (min count 31) result))
 294           (t
 295            ;; Count=0?  Shouldn't happen, but it's easy:
 296            (move number result)))))
 297
 298 ;;; FIXME: implement FAST-ASH-LEFT/UNSIGNED=>UNSIGNED and friends, for
 299 ;;; use in modular ASH (and because they're useful anyway).  -- CSR,
 300 ;;; 2004-08-16
 301
 302 (define-vop (signed-byte-32-len)
 303   (:translate integer-length)
 304   (:note "inline (signed-byte 32) integer-length")
 305   (:policy :fast-safe)
 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)
 311   (:generator 30
 312     (inst move arg shift :>=)
 313     (inst uaddcm zero-tn shift shift)
 314     (inst comb := shift zero-tn done)
 315     (inst li 0 res)
 316     LOOP
 317     (inst srl shift 1 shift)
 318     (inst comb :<> shift zero-tn loop)
 319     (inst addi (fixnumize 1) res res)
 320     DONE))
 321
 322 (define-vop (unsigned-byte-32-count)
 323   (:translate logcount)
 324   (:note "inline (unsigned-byte 32) logcount")
 325   (:policy :fast-safe)
 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)
 331                     :target res) num)
 332   (:temporary (:scs (non-descriptor-reg)) mask temp)
 333   (:generator 30
 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)))
 359
 360 ;;; Multiply and Divide.
 361
 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)
 375   (:ignore lip sign)
 376   (:translate *)
 377   (:generator 30
 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))
 386     (move res-pass r)))
 387
 388 (define-vop (fast-*/signed=>signed fast-signed-binop)
 389   (:translate *)
 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)
 402   (:ignore lip sign)
 403   (:translate *)
 404   (:generator 31
 405     (let ((fixup (make-fixup 'multiply :assembly-routine)))
 406       (move x x-pass)
 407       (move y y-pass)
 408       (inst ldil fixup tmp)
 409       (inst ble fixup lisp-heap-space tmp :nullify t)
 410       (inst nop)
 411       (move res-pass r))))
 412
 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))
 426             (r :scs (any-reg)))
 427   (:result-types tagged-num tagged-num)
 428   (:vop-var vop)
 429   (:save-p :compute-only)
 430   (:generator 30
 431     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 432       (inst bc := nil y zero-tn zero))
 433     (move x x-pass)
 434     (move y y-pass)
 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))
 438     (inst nop)
 439     (move q-pass q)
 440     (move r-pass r)))
 441
 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)
 457   (:vop-var vop)
 458   (:save-p :compute-only)
 459   (:generator 35
 460     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 461       (inst bc := nil y zero-tn zero))
 462     (move x x-pass)
 463     (move y y-pass)
 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))
 467     (inst nop)
 468     (move q-pass q)
 469     (move r-pass r)))
 470
 471 \f
 472 ;;;; Binary conditional VOPs:
 473
 474 (define-vop (fast-conditional)
 475   (:conditional)
 476   (:info target not-p)
 477   (:effects)
 478   (:affected)
 479   (:policy :fast-safe))
 480
 481 (define-vop (fast-conditional/fixnum fast-conditional)
 482   (:args (x :scs (any-reg))
 483          (y :scs (any-reg)))
 484   (:arg-types tagged-num tagged-num)
 485   (:note "inline fixnum comparison"))
 486
 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))
 491
 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"))
 497
 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))
 502
 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"))
 508
 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))
 513
 514
 515 (defmacro define-conditional-vop (translate signed-cond unsigned-cond)
 516   `(progn
 517      ,@(mapcar #'(lambda (suffix cost signed imm)
 518                    (unless (and (member suffix '(/fixnum -c/fixnum))
 519                                 (eq translate 'eql))
 520                      `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
 521                                                     translate suffix))
 522                                    ,(intern
 523                                      (format nil "~:@(FAST-CONDITIONAL~A~)"
 524                                              suffix)))
 525                         (:translate ,translate)
 526                         (:generator ,cost
 527                           (inst ,(if imm 'bci 'bc)
 528                                 ,(if signed signed-cond unsigned-cond)
 529                                 not-p
 530                                 ,(if (eq suffix '-c/fixnum)
 531                                      '(fixnumize y)
 532                                      'y)
 533                                 x
 534                                 target)))))
 535                '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
 536                '(3 2 5 4 5 4)
 537                '(t t t t nil nil)
 538                '(nil t nil t nil t))))
 539
 540 ;; We switch < and > because the immediate has to come first.
 541
 542 (define-conditional-vop < :> :>>)
 543 (define-conditional-vop > :< :<<)
 544
 545 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
 546 ;;; known fixnum.
 547 ;;;
 548 (define-conditional-vop eql := :=)
 549
 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.
 555 ;;;
 556 (define-vop (fast-eql/fixnum fast-conditional)
 557   (:args (x :scs (any-reg descriptor-reg))
 558          (y :scs (any-reg)))
 559   (:arg-types tagged-num tagged-num)
 560   (:note "inline fixnum comparison")
 561   (:translate eql)
 562   (:generator 3
 563     (inst bc := not-p x y target)))
 564 ;;;
 565 (define-vop (generic-eql/fixnum fast-eql/fixnum)
 566   (:arg-types * tagged-num)
 567   (:variant-cost 7))
 568
 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)
 573   (:translate eql)
 574   (:generator 2
 575     (inst bci := not-p (fixnumize y) x target)))
 576 ;;;
 577 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
 578   (:arg-types * (:constant (signed-byte 9)))
 579   (:variant-cost 6))
 580
 581 \f
 582 ;;;; modular functions
 583 (define-modular-fun +-mod32 (x y) + 32)
 584 (define-vop (fast-+-mod32/unsigned=>unsigned fast-+/unsigned=>unsigned)
 585   (:translate +-mod32))
 586 (define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned)
 587   (:translate +-mod32))
 588 (define-modular-fun --mod32 (x y) - 32)
 589 (define-vop (fast---mod32/unsigned=>unsigned fast--/unsigned=>unsigned)
 590   (:translate --mod32))
 591 (define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
 592   (:translate --mod32))
 593
 594 (define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
 595              fast-ash-c/unsigned=>unsigned)
 596   (:translate ash-left-mod32))
 597 (define-vop (fast-ash-left-mod32/unsigned=>unsigned
 598              ;; FIXME: when FAST-ASH-LEFT/UNSIGNED=>UNSIGNED is
 599              ;; implemented, use it here.  -- CSR, 2004-08-16
 600              fast-ash/unsigned=>unsigned))
 601 (deftransform ash-left-mod32 ((integer count)
 602                               ((unsigned-byte 32) (unsigned-byte 5)))
 603   (when (sb!c::constant-lvar-p count)
 604     (sb!c::give-up-ir1-transform))
 605   '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
 606
 607 (define-modular-fun lognot-mod32 (x) lognot 32)
 608 (define-vop (lognot-mod32/unsigned=>unsigned)
 609   (:translate lognot-mod32)
 610   (:args (x :scs (unsigned-reg)))
 611   (:arg-types unsigned-num)
 612   (:results (res :scs (unsigned-reg)))
 613   (:result-types unsigned-num)
 614   (:policy :fast-safe)
 615   (:generator 1
 616     (inst uaddcm zero-tn x res)))
 617
 618 (macrolet
 619     ((define-modular-backend (fun)
 620        (let ((mfun-name (symbolicate fun '-mod32))
 621              ;; FIXME: if anyone cares, add constant-arg vops.  --
 622              ;; CSR, 2003-09-16
 623              (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
 624              (vop (symbolicate 'fast- fun '/unsigned=>unsigned)))
 625          `(progn
 626             (define-modular-fun ,mfun-name (x y) ,fun 32)
 627             (define-vop (,modvop ,vop)
 628               (:translate ,mfun-name))))))
 629   (define-modular-backend logxor)
 630   (define-modular-backend logandc1)
 631   (define-modular-backend logandc2))
 632
 633 (define-source-transform logeqv (&rest args)
 634   (if (oddp (length args))
 635       `(logxor ,@args)
 636       `(lognot (logxor ,@args))))
 637 (define-source-transform logorc1 (x y)
 638   `(logior (lognot ,x) ,y))
 639 (define-source-transform logorc2 (x y)
 640   `(logior ,x (lognot ,y)))
 641 (define-source-transform lognand (x y)
 642   `(lognot (logand ,x ,y)))
 643 (define-source-transform lognor (x y)
 644   `(lognot (logior ,x y)))
 645
 646 (define-vop (shift-towards-someplace)
 647   (:policy :fast-safe)
 648   (:args (num :scs (unsigned-reg))
 649          (amount :scs (signed-reg)))
 650   (:arg-types unsigned-num tagged-num)
 651   (:results (r :scs (unsigned-reg)))
 652   (:result-types unsigned-num))
 653
 654 (define-vop (shift-towards-start shift-towards-someplace)
 655   (:translate shift-towards-start)
 656   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 657   (:note "SHIFT-TOWARDS-START")
 658   (:generator 1
 659     (inst subi 31 amount temp)
 660     (inst mtctl temp :sar)
 661     (inst zdep num :variable 32 r)))
 662
 663 (define-vop (shift-towards-end shift-towards-someplace)
 664   (:translate shift-towards-end)
 665   (:note "SHIFT-TOWARDS-END")
 666   (:generator 1
 667     (inst mtctl amount :sar)
 668     (inst shd zero-tn num :variable r)))
 669
 670
 671 \f
 672 ;;;; Bignum stuff.
 673
 674 (define-vop (bignum-length get-header-data)
 675   (:translate sb!bignum:%bignum-length)
 676   (:policy :fast-safe))
 677
 678 (define-vop (bignum-set-length set-header-data)
 679   (:translate sb!bignum:%bignum-set-length)
 680   (:policy :fast-safe))
 681
 682 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
 683   (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
 684
 685 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
 686   (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
 687
 688 (define-vop (digit-0-or-plus)
 689   (:translate sb!bignum:%digit-0-or-plusp)
 690   (:policy :fast-safe)
 691   (:args (digit :scs (unsigned-reg)))
 692   (:arg-types unsigned-num)
 693   (:conditional)
 694   (:info target not-p)
 695   (:effects)
 696   (:affected)
 697   (:generator 1
 698     (inst bc :>= not-p digit zero-tn target)))
 699
 700 (define-vop (add-w/carry)
 701   (:translate sb!bignum:%add-with-carry)
 702   (:policy :fast-safe)
 703   (:args (a :scs (unsigned-reg))
 704          (b :scs (unsigned-reg))
 705          (c :scs (unsigned-reg)))
 706   (:arg-types unsigned-num unsigned-num positive-fixnum)
 707   (:results (result :scs (unsigned-reg))
 708             (carry :scs (unsigned-reg)))
 709   (:result-types unsigned-num positive-fixnum)
 710   (:generator 3
 711     (inst addi -1 c zero-tn)
 712     (inst addc a b result)
 713     (inst addc zero-tn zero-tn carry)))
 714
 715 (define-vop (sub-w/borrow)
 716   (:translate sb!bignum:%subtract-with-borrow)
 717   (:policy :fast-safe)
 718   (:args (a :scs (unsigned-reg))
 719          (b :scs (unsigned-reg))
 720          (c :scs (unsigned-reg)))
 721   (:arg-types unsigned-num unsigned-num positive-fixnum)
 722   (:results (result :scs (unsigned-reg))
 723             (borrow :scs (unsigned-reg)))
 724   (:result-types unsigned-num positive-fixnum)
 725   (:generator 4
 726     (inst addi -1 c zero-tn)
 727     (inst subb a b result)
 728     (inst addc zero-tn zero-tn borrow)))
 729
 730 (define-vop (bignum-mult)
 731   (:translate sb!bignum:%multiply)
 732   (:policy :fast-safe)
 733   (:args (x-arg :scs (unsigned-reg) :target x)
 734          (y-arg :scs (unsigned-reg) :target y))
 735   (:arg-types unsigned-num unsigned-num)
 736   (:temporary (:scs (signed-reg) :from (:argument 0)) x)
 737   (:temporary (:scs (signed-reg) :from (:argument 1)) y)
 738   (:temporary (:scs (signed-reg)) tmp)
 739   (:results (hi :scs (unsigned-reg))
 740             (lo :scs (unsigned-reg)))
 741   (:result-types unsigned-num unsigned-num)
 742   (:generator 3
 743     ;; Make sure X is less then Y.
 744     (inst comclr x-arg y-arg tmp :<<)
 745     (inst xor x-arg y-arg tmp)
 746     (inst xor x-arg tmp x)
 747     (inst xor y-arg tmp y)
 748
 749     ;; Blow out of here if the result is zero.
 750     (inst li 0 hi)
 751     (inst comb := x zero-tn done)
 752     (inst li 0 lo)
 753     (inst li 0 tmp)
 754
 755     LOOP
 756     (inst comb :ev x zero-tn next-bit)
 757     (inst srl x 1 x)
 758     (inst add lo y lo)
 759     (inst addc hi tmp hi)
 760     NEXT-BIT
 761     (inst add y y y)
 762     (inst comb :<> x zero-tn loop)
 763     (inst addc tmp tmp tmp)
 764
 765     DONE))
 766
 767 (define-source-transform sb!bignum:%multiply-and-add (x y carry &optional (extra 0))
 768   #+nil ;; This would be greate if it worked, but it doesn't.
 769   (if (eql extra 0)
 770       `(multiple-value-call #'sb!bignum:%dual-word-add
 771          (sb!bignum:%multiply ,x ,y)
 772          (values ,carry))
 773       `(multiple-value-call #'sb!bignum:%dual-word-add
 774          (multiple-value-call #'sb!bignum:%dual-word-add
 775            (sb!bignum:%multiply ,x ,y)
 776            (values ,carry))
 777          (values ,extra)))
 778   (with-unique-names (hi lo)
 779     (if (eql extra 0)
 780         `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
 781            (sb!bignum::%dual-word-add ,hi ,lo ,carry))
 782         `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
 783            (multiple-value-bind
 784                (,hi ,lo)
 785                (sb!bignum::%dual-word-add ,hi ,lo ,carry)
 786              (sb!bignum::%dual-word-add ,hi ,lo ,extra))))))
 787
 788 (defknown sb!bignum::%dual-word-add
 789           (sb!bignum:bignum-element-type sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
 790   (values sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
 791   (flushable movable))
 792
 793 (define-vop (dual-word-add)
 794   (:policy :fast-safe)
 795   (:translate sb!bignum::%dual-word-add)
 796   (:args (hi :scs (unsigned-reg) :to (:result 1))
 797          (lo :scs (unsigned-reg))
 798          (extra :scs (unsigned-reg)))
 799   (:arg-types unsigned-num unsigned-num unsigned-num)
 800   (:results (hi-res :scs (unsigned-reg) :from (:result 1))
 801             (lo-res :scs (unsigned-reg) :from (:result 0)))
 802   (:result-types unsigned-num unsigned-num)
 803   (:affected)
 804   (:effects)
 805   (:generator 3
 806     (inst add lo extra lo-res)
 807     (inst addc hi zero-tn hi-res)))
 808
 809 (define-vop (bignum-lognot)
 810   (:translate sb!bignum:%lognot)
 811   (:policy :fast-safe)
 812   (:args (x :scs (unsigned-reg)))
 813   (:arg-types unsigned-num)
 814   (:results (r :scs (unsigned-reg)))
 815   (:result-types unsigned-num)
 816   (:generator 1
 817     (inst uaddcm zero-tn x r)))
 818
 819 (define-vop (fixnum-to-digit)
 820   (:translate sb!bignum:%fixnum-to-digit)
 821   (:policy :fast-safe)
 822   (:args (fixnum :scs (signed-reg)))
 823   (:arg-types tagged-num)
 824   (:results (digit :scs (unsigned-reg)))
 825   (:result-types unsigned-num)
 826   (:generator 1
 827     (move fixnum digit)))
 828
 829 (define-vop (bignum-floor)
 830   (:translate sb!bignum:%floor)
 831   (:policy :fast-safe)
 832   (:args (hi :scs (unsigned-reg) :to (:argument 1))
 833          (lo :scs (unsigned-reg) :to (:argument 0))
 834          (divisor :scs (unsigned-reg)))
 835   (:arg-types unsigned-num unsigned-num unsigned-num)
 836   (:temporary (:scs (unsigned-reg) :to (:argument 1)) temp)
 837   (:results (quo :scs (unsigned-reg) :from (:argument 0))
 838             (rem :scs (unsigned-reg) :from (:argument 1)))
 839   (:result-types unsigned-num unsigned-num)
 840   (:generator 65
 841     (inst sub zero-tn divisor temp)
 842     (inst ds zero-tn temp zero-tn)
 843     (inst add lo lo quo)
 844     (inst ds hi divisor rem)
 845     (inst addc quo quo quo)
 846     (dotimes (i 31)
 847       (inst ds rem divisor rem)
 848       (inst addc quo quo quo))
 849     (inst comclr rem zero-tn zero-tn :>=)
 850     (inst add divisor rem rem)))
 851
 852 (define-vop (signify-digit)
 853   (:translate sb!bignum:%fixnum-digit-with-correct-sign)
 854   (:policy :fast-safe)
 855   (:args (digit :scs (unsigned-reg) :target res))
 856   (:arg-types unsigned-num)
 857   (:results (res :scs (signed-reg)))
 858   (:result-types signed-num)
 859   (:generator 1
 860     (move digit res)))
 861
 862 (define-vop (digit-lshr)
 863   (:translate sb!bignum:%digit-logical-shift-right)
 864   (:policy :fast-safe)
 865   (:args (digit :scs (unsigned-reg))
 866          (count :scs (unsigned-reg)))
 867   (:arg-types unsigned-num positive-fixnum)
 868   (:results (result :scs (unsigned-reg)))
 869   (:result-types unsigned-num)
 870   (:generator 2
 871     (inst mtctl count :sar)
 872     (inst shd zero-tn digit :variable result)))
 873
 874 (define-vop (digit-ashr digit-lshr)
 875   (:translate sb!bignum:%ashr)
 876   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 877   (:generator 1
 878     (inst extrs digit 0 1 temp)
 879     (inst mtctl count :sar)
 880     (inst shd temp digit :variable result)))
 881
 882 (define-vop (digit-ashl digit-ashr)
 883   (:translate sb!bignum:%ashl)
 884   (:generator 1
 885     (inst subi 31 count temp)
 886     (inst mtctl temp :sar)
 887     (inst zdep digit :variable 32 result)))
 888
 889 \f
 890 ;;;; Static functions.
 891
 892 (define-static-fun two-arg-gcd (x y) :translate gcd)
 893 (define-static-fun two-arg-lcm (x y) :translate lcm)
 894
 895 (define-static-fun two-arg-* (x y) :translate *)
 896 (define-static-fun two-arg-/ (x y) :translate /)
 897
 898 (define-static-fun %negate (x) :translate %negate)
 899
 900 (define-static-fun two-arg-and (x y) :translate logand)
 901 (define-static-fun two-arg-ior (x y) :translate logior)
 902 (define-static-fun two-arg-xor (x y) :translate logxor)