src/compiler/mips/arith.lisp

   1 (in-package "SB!VM")
   2
   3
   4 \f
   5 ;;;; Unary operations.
   6
   7 (define-vop (fixnum-unop)
   8   (:args (x :scs (any-reg)))
   9   (:results (res :scs (any-reg)))
  10   (:note "inline fixnum arithmetic")
  11   (:arg-types tagged-num)
  12   (:result-types tagged-num)
  13   (:policy :fast-safe))
  14
  15 (define-vop (signed-unop)
  16   (:args (x :scs (signed-reg)))
  17   (:results (res :scs (signed-reg)))
  18   (:note "inline (signed-byte 32) arithmetic")
  19   (:arg-types signed-num)
  20   (:result-types signed-num)
  21   (:policy :fast-safe))
  22
  23 (define-vop (fast-negate/fixnum fixnum-unop)
  24   (:translate %negate)
  25   (:generator 1
  26     (inst subu res zero-tn x)))
  27
  28 (define-vop (fast-negate/signed signed-unop)
  29   (:translate %negate)
  30   (:generator 2
  31     (inst subu res zero-tn x)))
  32
  33 (define-vop (fast-lognot/fixnum fixnum-unop)
  34   (:temporary (:scs (any-reg) :type fixnum :to (:result 0))
  35               temp)
  36   (:translate lognot)
  37   (:generator 2
  38     (inst li temp (fixnumize -1))
  39     (inst xor res x temp)))
  40
  41 (define-vop (fast-lognot/signed signed-unop)
  42   (:translate lognot)
  43   (:generator 1
  44     (inst nor res x zero-tn)))
  45
  46
  47 \f
  48 ;;;; Binary fixnum operations.
  49
  50 ;;; Assume that any constant operand is the second arg...
  51
  52 (define-vop (fast-fixnum-binop)
  53   (:args (x :target r :scs (any-reg))
  54          (y :target r :scs (any-reg)))
  55   (:arg-types tagged-num tagged-num)
  56   (:results (r :scs (any-reg)))
  57   (:result-types tagged-num)
  58   (:note "inline fixnum arithmetic")
  59   (:effects)
  60   (:affected)
  61   (:policy :fast-safe))
  62
  63 (define-vop (fast-unsigned-binop)
  64   (:args (x :target r :scs (unsigned-reg))
  65          (y :target r :scs (unsigned-reg)))
  66   (:arg-types unsigned-num unsigned-num)
  67   (:results (r :scs (unsigned-reg)))
  68   (:result-types unsigned-num)
  69   (:note "inline (unsigned-byte 32) arithmetic")
  70   (:effects)
  71   (:affected)
  72   (:policy :fast-safe))
  73
  74 (define-vop (fast-signed-binop)
  75   (:args (x :target r :scs (signed-reg))
  76          (y :target r :scs (signed-reg)))
  77   (:arg-types signed-num signed-num)
  78   (:results (r :scs (signed-reg)))
  79   (:result-types signed-num)
  80   (:note "inline (signed-byte 32) arithmetic")
  81   (:effects)
  82   (:affected)
  83   (:policy :fast-safe))
  84
  85 (define-vop (fast-fixnum-c-binop fast-fixnum-binop)
  86   (:args (x :target r :scs (any-reg)))
  87   (:info y)
  88   (:arg-types tagged-num (:constant integer)))
  89
  90 (define-vop (fast-signed-c-binop fast-signed-binop)
  91   (:args (x :target r :scs (signed-reg)))
  92   (:info y)
  93   (:arg-types tagged-num (:constant integer)))
  94
  95 (define-vop (fast-unsigned-c-binop fast-unsigned-binop)
  96   (:args (x :target r :scs (unsigned-reg)))
  97   (:info y)
  98   (:arg-types tagged-num (:constant integer)))
  99
 100 (defmacro define-binop (translate cost untagged-cost op
 101                                   tagged-type untagged-type)
 102   `(progn
 103      (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
 104                   fast-fixnum-binop)
 105        (:args (x :target r :scs (any-reg))
 106               (y :target r :scs (any-reg)))
 107        (:translate ,translate)
 108        (:generator ,(1+ cost)
 109          (inst ,op r x y)))
 110      (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
 111                   fast-signed-binop)
 112        (:args (x :target r :scs (signed-reg))
 113               (y :target r :scs (signed-reg)))
 114        (:translate ,translate)
 115        (:generator ,(1+ untagged-cost)
 116          (inst ,op r x y)))
 117      (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
 118                   fast-unsigned-binop)
 119        (:args (x :target r :scs (unsigned-reg))
 120               (y :target r :scs (unsigned-reg)))
 121        (:translate ,translate)
 122        (:generator ,(1+ untagged-cost)
 123          (inst ,op r x y)))
 124      ,@(when tagged-type
 125          `((define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
 126                         fast-fixnum-c-binop)
 127                        (:arg-types tagged-num (:constant ,tagged-type))
 128              (:translate ,translate)
 129              (:generator ,cost
 130                          (inst ,op r x (fixnumize y))))))
 131      ,@(when untagged-type
 132          `((define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
 133                         fast-signed-c-binop)
 134                        (:arg-types signed-num (:constant ,untagged-type))
 135              (:translate ,translate)
 136              (:generator ,untagged-cost
 137                          (inst ,op r x y)))
 138            (define-vop (,(symbolicate "FAST-" translate
 139                                       "-C/UNSIGNED=>UNSIGNED")
 140                         fast-unsigned-c-binop)
 141                        (:arg-types unsigned-num (:constant ,untagged-type))
 142              (:translate ,translate)
 143              (:generator ,untagged-cost
 144                          (inst ,op r x y)))))))
 145
 146 (define-binop + 1 5 addu (signed-byte 14) (signed-byte 16))
 147 (define-binop - 1 5 subu
 148   (integer #.(- (1- (ash 1 14))) #.(ash 1 14))
 149   (integer #.(- (1- (ash 1 16))) #.(ash 1 16)))
 150 (define-binop logior 1 3 or (unsigned-byte 14) (unsigned-byte 16))
 151 (define-binop logand 1 3 and (unsigned-byte 14) (unsigned-byte 16))
 152 (define-binop logxor 1 3 xor (unsigned-byte 14) (unsigned-byte 16))
 153
 154 ;;; KLUDGE: no FIXNUM VOP for LOGNOR, because there's no efficient way
 155 ;;; of restoring the tag bits.  (No -C/ VOPs for LOGNOR because the
 156 ;;; NOR instruction doesn't take immediate args).  -- CSR, 2003-09-11
 157 (define-vop (fast-lognor/signed=>signed fast-signed-binop)
 158   (:translate lognor)
 159   (:args (x :target r :scs (signed-reg))
 160          (y :target r :scs (signed-reg)))
 161   (:generator 4
 162     (inst nor r x y)))
 163 (define-vop (fast-lognor/unsigned=>unsigned fast-unsigned-binop)
 164   (:translate lognor)
 165   (:args (x :target r :scs (unsigned-reg))
 166          (y :target r :scs (unsigned-reg)))
 167   (:generator 4
 168     (inst nor r x y)))
 169
 170 ;;; Special case fixnum + and - that trap on overflow.  Useful when we don't
 171 ;;; know that the result is going to be a fixnum.
 172 #+nil
 173 (progn
 174   (define-vop (fast-+/fixnum fast-+/fixnum=>fixnum)
 175       (:results (r :scs (any-reg descriptor-reg)))
 176     (:result-types (:or signed-num unsigned-num))
 177     (:note nil)
 178     (:generator 4
 179                 (inst add r x y)))
 180
 181   (define-vop (fast-+-c/fixnum fast-+-c/fixnum=>fixnum)
 182       (:results (r :scs (any-reg descriptor-reg)))
 183     (:result-types (:or signed-num unsigned-num))
 184     (:note nil)
 185     (:generator 3
 186                 (inst add r x (fixnumize y))))
 187
 188   (define-vop (fast--/fixnum fast--/fixnum=>fixnum)
 189       (:results (r :scs (any-reg descriptor-reg)))
 190     (:result-types (:or signed-num unsigned-num))
 191     (:note nil)
 192     (:generator 4
 193                 (inst sub r x y)))
 194
 195   (define-vop (fast---c/fixnum fast---c/fixnum=>fixnum)
 196       (:results (r :scs (any-reg descriptor-reg)))
 197     (:result-types (:or signed-num unsigned-num))
 198     (:note nil)
 199     (:generator 3
 200                 (inst sub r x (fixnumize y))))
 201 ) ; bogus trap-to-c-land +/-
 202
 203 ;;; Shifting
 204
 205 (define-vop (fast-ash/unsigned=>unsigned)
 206   (:note "inline ASH")
 207   (:args (number :scs (unsigned-reg) :to :save)
 208          (amount :scs (signed-reg) :to :save))
 209   (:arg-types unsigned-num signed-num)
 210   (:results (result :scs (unsigned-reg)))
 211   (:result-types unsigned-num)
 212   (:translate ash)
 213   (:policy :fast-safe)
 214   (:temporary (:sc non-descriptor-reg) ndesc)
 215   (:temporary (:sc non-descriptor-reg :to :eval) temp)
 216   (:generator 3
 217     (inst bgez amount positive)
 218     (inst subu ndesc zero-tn amount)
 219     (inst slt temp ndesc 32)
 220     (inst bne temp zero-tn done)
 221     (inst srl result number ndesc)
 222     (inst b done)
 223     (inst move result zero-tn)
 224
 225     POSITIVE
 226     ;; The result-type assures us that this shift will not overflow.
 227     (inst sll result number amount)
 228
 229     DONE))
 230
 231 (define-vop (fast-ash/signed=>signed)
 232   (:note "inline ASH")
 233   (:args (number :scs (signed-reg) :to :save)
 234          (amount :scs (signed-reg)))
 235   (:arg-types signed-num signed-num)
 236   (:results (result :scs (signed-reg)))
 237   (:result-types signed-num)
 238   (:translate ash)
 239   (:policy :fast-safe)
 240   (:temporary (:sc non-descriptor-reg) ndesc)
 241   (:temporary (:sc non-descriptor-reg :to :eval) temp)
 242   (:generator 3
 243     (inst bgez amount positive)
 244     (inst subu ndesc zero-tn amount)
 245     (inst slt temp ndesc 31)
 246     (inst bne temp zero-tn done)
 247     (inst sra result number ndesc)
 248     (inst b done)
 249     (inst sra result number 31)
 250
 251     POSITIVE
 252     ;; The result-type assures us that this shift will not overflow.
 253     (inst sll result number amount)
 254
 255     DONE))
 256
 257
 258 (define-vop (fast-ash-c/unsigned=>unsigned)
 259   (:policy :fast-safe)
 260   (:translate ash)
 261   (:note "inline ASH")
 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 result number (min (- count) 31)))
 271           ((> count 0)
 272            ;; It is a left shift.
 273            (inst sll result number (min count 31)))
 274           (t
 275            ;; Count=0?  Shouldn't happen, but it's easy:
 276            (move result number)))))
 277
 278 (define-vop (fast-ash-c/signed=>signed)
 279   (:policy :fast-safe)
 280   (:translate ash)
 281   (:note "inline ASH")
 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 result number (min (- count) 31)))
 291           ((> count 0)
 292            ;; It is a left shift.
 293            (inst sll result number (min count 31)))
 294           (t
 295            ;; Count=0?  Shouldn't happen, but it's easy:
 296            (move result number)))))
 297
 298 (define-vop (signed-byte-32-len)
 299   (:translate integer-length)
 300   (:note "inline (signed-byte 32) integer-length")
 301   (:policy :fast-safe)
 302   (:args (arg :scs (signed-reg) :target shift))
 303   (:arg-types signed-num)
 304   (:results (res :scs (any-reg)))
 305   (:result-types positive-fixnum)
 306   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
 307   (:generator 30
 308     (let ((loop (gen-label))
 309           (test (gen-label)))
 310       (move shift arg)
 311       (inst bgez shift test)
 312       (move res zero-tn)
 313       (inst b test)
 314       (inst nor shift shift)
 315
 316       (emit-label loop)
 317       (inst add res (fixnumize 1))
 318
 319       (emit-label test)
 320       (inst bne shift loop)
 321       (inst srl shift 1))))
 322
 323 (define-vop (unsigned-byte-32-count)
 324   (:translate logcount)
 325   (:note "inline (unsigned-byte 32) logcount")
 326   (:policy :fast-safe)
 327   (:args (arg :scs (unsigned-reg) :target num))
 328   (:arg-types unsigned-num)
 329   (:results (res :scs (unsigned-reg)))
 330   (:result-types positive-fixnum)
 331   (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0)
 332                     :target res) num)
 333   (:temporary (:scs (non-descriptor-reg)) mask temp)
 334   (:generator 30
 335     (inst li mask #x55555555)
 336     (inst srl temp arg 1)
 337     (inst and num arg mask)
 338     (inst and temp mask)
 339     (inst addu num temp)
 340     (inst li mask #x33333333)
 341     (inst srl temp num 2)
 342     (inst and num mask)
 343     (inst and temp mask)
 344     (inst addu num temp)
 345     (inst li mask #x0f0f0f0f)
 346     (inst srl temp num 4)
 347     (inst and num mask)
 348     (inst and temp mask)
 349     (inst addu num temp)
 350     (inst li mask #x00ff00ff)
 351     (inst srl temp num 8)
 352     (inst and num mask)
 353     (inst and temp mask)
 354     (inst addu num temp)
 355     (inst li mask #x0000ffff)
 356     (inst srl temp num 16)
 357     (inst and num mask)
 358     (inst and temp mask)
 359     (inst addu res num temp)))
 360
 361
 362 ;;; Multiply and Divide.
 363
 364 (define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
 365   (:temporary (:scs (non-descriptor-reg)) temp)
 366   (:translate *)
 367   (:generator 4
 368     (inst sra temp y 2)
 369     (inst mult x temp)
 370     (inst mflo r)))
 371
 372 (define-vop (fast-*/signed=>signed fast-signed-binop)
 373   (:translate *)
 374   (:generator 3
 375     (inst mult x y)
 376     (inst mflo r)))
 377
 378 (define-vop (fast-*/unsigned=>unsigned fast-unsigned-binop)
 379   (:translate *)
 380   (:generator 3
 381     (inst multu x y)
 382     (inst mflo r)))
 383
 384
 385
 386 (define-vop (fast-truncate/fixnum fast-fixnum-binop)
 387   (:translate truncate)
 388   (:results (q :scs (any-reg))
 389             (r :scs (any-reg)))
 390   (:result-types tagged-num tagged-num)
 391   (:temporary (:scs (non-descriptor-reg) :to :eval) temp)
 392   (:vop-var vop)
 393   (:save-p :compute-only)
 394   (:generator 11
 395     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 396       (inst beq y zero-tn zero))
 397     (inst nop)
 398     (inst div x y)
 399     (inst mflo temp)
 400     (inst sll q temp 2)
 401     (inst mfhi r)))
 402
 403 (define-vop (fast-truncate/unsigned fast-unsigned-binop)
 404   (:translate truncate)
 405   (:results (q :scs (unsigned-reg))
 406             (r :scs (unsigned-reg)))
 407   (:result-types unsigned-num unsigned-num)
 408   (:vop-var vop)
 409   (:save-p :compute-only)
 410   (:generator 12
 411     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 412       (inst beq y zero-tn zero))
 413     (inst nop)
 414     (inst divu x y)
 415     (inst mflo q)
 416     (inst mfhi r)))
 417
 418 (define-vop (fast-truncate/signed fast-signed-binop)
 419   (:translate truncate)
 420   (:results (q :scs (signed-reg))
 421             (r :scs (signed-reg)))
 422   (:result-types signed-num signed-num)
 423   (:vop-var vop)
 424   (:save-p :compute-only)
 425   (:generator 12
 426     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 427       (inst beq y zero-tn zero))
 428     (inst nop)
 429     (inst div x y)
 430     (inst mflo q)
 431     (inst mfhi r)))
 432
 433
 434 \f
 435 ;;;; Binary conditional VOPs:
 436
 437 (define-vop (fast-conditional)
 438   (:conditional)
 439   (:info target not-p)
 440   (:effects)
 441   (:affected)
 442   (:temporary (:scs (non-descriptor-reg)) temp)
 443   (:policy :fast-safe))
 444
 445 (define-vop (fast-conditional/fixnum fast-conditional)
 446   (:args (x :scs (any-reg))
 447          (y :scs (any-reg)))
 448   (:arg-types tagged-num tagged-num)
 449   (:note "inline fixnum comparison"))
 450
 451 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
 452   (:args (x :scs (any-reg)))
 453   (:arg-types tagged-num (:constant (signed-byte-with-a-bite-out 14 4)))
 454   (:info target not-p y))
 455
 456 (define-vop (fast-conditional/signed fast-conditional)
 457   (:args (x :scs (signed-reg))
 458          (y :scs (signed-reg)))
 459   (:arg-types signed-num signed-num)
 460   (:note "inline (signed-byte 32) comparison"))
 461
 462 (define-vop (fast-conditional-c/signed fast-conditional/signed)
 463   (:args (x :scs (signed-reg)))
 464   (:arg-types signed-num (:constant (signed-byte-with-a-bite-out 16 1)))
 465   (:info target not-p y))
 466
 467 (define-vop (fast-conditional/unsigned fast-conditional)
 468   (:args (x :scs (unsigned-reg))
 469          (y :scs (unsigned-reg)))
 470   (:arg-types unsigned-num unsigned-num)
 471   (:note "inline (unsigned-byte 32) comparison"))
 472
 473 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
 474   (:args (x :scs (unsigned-reg)))
 475   (:arg-types unsigned-num (:constant (and (signed-byte-with-a-bite-out 16 1)
 476                                            unsigned-byte)))
 477   (:info target not-p y))
 478
 479
 480 (defmacro define-conditional-vop (translate &rest generator)
 481   `(progn
 482      ,@(mapcar #'(lambda (suffix cost signed)
 483                    (unless (and (member suffix '(/fixnum -c/fixnum))
 484                                 (eq translate 'eql))
 485                      `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
 486                                                     translate suffix))
 487                                    ,(intern
 488                                      (format nil "~:@(FAST-CONDITIONAL~A~)"
 489                                              suffix)))
 490                         (:translate ,translate)
 491                         (:generator ,cost
 492                           (let* ((signed ,signed)
 493                                  (-c/fixnum ,(eq suffix '-c/fixnum))
 494                                  (y (if -c/fixnum (fixnumize y) y)))
 495                             (declare (ignorable signed -c/fixnum y))
 496                             ,@generator)))))
 497                '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
 498                '(3 2 5 4 5 4)
 499                '(t t t t nil nil))))
 500
 501 (define-conditional-vop <
 502   (cond ((and signed (eql y 0))
 503          (if not-p
 504              (inst bgez x target)
 505              (inst bltz x target)))
 506         (t
 507          (if signed
 508              (inst slt temp x y)
 509              (inst sltu temp x y))
 510          (if not-p
 511              (inst beq temp zero-tn target)
 512              (inst bne temp zero-tn target))))
 513   (inst nop))
 514
 515 (define-conditional-vop >
 516   (cond ((and signed (eql y 0))
 517          (if not-p
 518              (inst blez x target)
 519              (inst bgtz x target)))
 520         ((integerp y)
 521          (let ((y (+ y (if -c/fixnum (fixnumize 1) 1))))
 522            (if signed
 523                (inst slt temp x y)
 524                (inst sltu temp x y))
 525            (if not-p
 526                (inst bne temp zero-tn target)
 527                (inst beq temp zero-tn target))))
 528         (t
 529          (if signed
 530              (inst slt temp y x)
 531              (inst sltu temp y x))
 532          (if not-p
 533              (inst beq temp zero-tn target)
 534              (inst bne temp zero-tn target))))
 535   (inst nop))
 536
 537 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
 538 ;;; known fixnum.
 539
 540 (define-conditional-vop eql
 541   (declare (ignore signed))
 542   (when (integerp y)
 543     (inst li temp y)
 544     (setf y temp))
 545   (if not-p
 546       (inst bne x y target)
 547       (inst beq x y target))
 548   (inst nop))
 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))
 558          (y :scs (any-reg)))
 559   (:arg-types tagged-num tagged-num)
 560   (:note "inline fixnum comparison")
 561   (:translate eql)
 562   (:ignore temp)
 563   (:generator 3
 564     (if not-p
 565         (inst bne x y target)
 566         (inst beq x y target))
 567     (inst nop)))
 568 ;;;
 569 (define-vop (generic-eql/fixnum fast-eql/fixnum)
 570   (:args (x :scs (any-reg descriptor-reg))
 571          (y :scs (any-reg)))
 572   (:arg-types * tagged-num)
 573   (:variant-cost 7))
 574
 575 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
 576   (:args (x :scs (any-reg)))
 577   (:arg-types tagged-num (:constant (signed-byte 14)))
 578   (:info target not-p y)
 579   (:translate eql)
 580   (:generator 2
 581     (let ((y (cond ((eql y 0) zero-tn)
 582                    (t
 583                     (inst li temp (fixnumize y))
 584                     temp))))
 585       (if not-p
 586           (inst bne x y target)
 587           (inst beq x y target))
 588       (inst nop))))
 589 ;;;
 590 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
 591   (:args (x :scs (any-reg descriptor-reg)))
 592   (:arg-types * (:constant (signed-byte 14)))
 593   (:variant-cost 6))
 594
 595 \f
 596 ;;;; 32-bit logical operations
 597
 598 (define-vop (merge-bits)
 599   (:translate merge-bits)
 600   (:args (shift :scs (signed-reg unsigned-reg))
 601          (prev :scs (unsigned-reg))
 602          (next :scs (unsigned-reg)))
 603   (:arg-types tagged-num unsigned-num unsigned-num)
 604   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 605   (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
 606   (:results (result :scs (unsigned-reg)))
 607   (:result-types unsigned-num)
 608   (:policy :fast-safe)
 609   (:generator 4
 610     (let ((done (gen-label)))
 611       (inst beq shift done)
 612       (inst srl res next shift)
 613       (inst subu temp zero-tn shift)
 614       (inst sll temp prev temp)
 615       (inst or res res temp)
 616       (emit-label done)
 617       (move result res))))
 618
 619 (define-source-transform 32bit-logical-not (x)
 620   `(logand (lognot (the (unsigned-byte 32) ,x)) #.(1- (ash 1 32))))
 621
 622 (deftransform 32bit-logical-and ((x y))
 623   '(logand x y))
 624
 625 (define-source-transform 32bit-logical-nand (x y)
 626   `(32bit-logical-not (32bit-logical-and ,x ,y)))
 627
 628 (deftransform 32bit-logical-or ((x y))
 629   '(logior x y))
 630
 631 (define-source-transform 32bit-logical-nor (x y)
 632   `(logand (lognor (the (unsigned-byte 32) ,x) (the (unsigned-byte 32) ,y))
 633            #.(1- (ash 1 32))))
 634
 635 (deftransform 32bit-logical-xor ((x y))
 636   '(logxor x y))
 637
 638 (define-source-transform 32bit-logical-eqv (x y)
 639   `(32bit-logical-not (32bit-logical-xor ,x ,y)))
 640
 641 (define-source-transform 32bit-logical-orc1 (x y)
 642   `(32bit-logical-or (32bit-logical-not ,x) ,y))
 643
 644 (define-source-transform 32bit-logical-orc2 (x y)
 645   `(32bit-logical-or ,x (32bit-logical-not ,y)))
 646
 647 (define-source-transform 32bit-logical-andc1 (x y)
 648   `(32bit-logical-and (32bit-logical-not ,x) ,y))
 649
 650 (define-source-transform 32bit-logical-andc2 (x y)
 651   `(32bit-logical-and ,x (32bit-logical-not ,y)))
 652
 653 (define-vop (shift-towards-someplace)
 654   (:policy :fast-safe)
 655   (:args (num :scs (unsigned-reg))
 656          (amount :scs (signed-reg)))
 657   (:arg-types unsigned-num tagged-num)
 658   (:results (r :scs (unsigned-reg)))
 659   (:result-types unsigned-num))
 660
 661 (define-vop (shift-towards-start shift-towards-someplace)
 662   (:translate shift-towards-start)
 663   (:note "SHIFT-TOWARDS-START")
 664   (:generator 1
 665     (ecase *backend-byte-order*
 666       (:big-endian
 667        (inst sll r num amount))
 668       (:little-endian
 669        (inst srl r num amount)))))
 670
 671 (define-vop (shift-towards-end shift-towards-someplace)
 672   (:translate shift-towards-end)
 673   (:note "SHIFT-TOWARDS-END")
 674   (:generator 1
 675     (ecase *backend-byte-order*
 676       (:big-endian
 677        (inst srl r num amount))
 678       (:little-endian
 679        (inst sll r num amount)))))
 680 \f
 681 ;;;; Modular arithmetic
 682 (define-modular-fun +-mod32 (x y) + 32)
 683 (define-vop (fast-+-mod32/unsigned=>unsigned fast-+/unsigned=>unsigned)
 684   (:translate +-mod32))
 685 (define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned)
 686   (:translate +-mod32))
 687
 688 ;;; logical operations
 689 (define-modular-fun lognot-mod32 (x) lognot 32)
 690 (define-vop (lognot-mod32/unsigned=>unsigned)
 691   (:translate lognot-mod32)
 692   (:args (x :scs (unsigned-reg)))
 693   (:arg-types unsigned-num)
 694   (:results (r :scs (unsigned-reg)))
 695   (:result-types unsigned-num)
 696   (:policy :fast-safe)
 697   (:generator 1
 698     (inst nor r x zero-tn)))
 699
 700 (define-modular-fun logxor-mod32 (x y) logxor 32)
 701 (define-vop (fast-logxor-mod32/unsigned=>unsigned
 702              fast-logxor/unsigned=>unsigned)
 703   (:translate logxor-mod32))
 704 (define-vop (fast-logxor-mod32-c/unsigned=>unsigned
 705              fast-logxor-c/unsigned=>unsigned)
 706   (:translate logxor-mod32))
 707
 708 (define-modular-fun lognor-mod32 (x y) lognor 32)
 709 (define-vop (fast-lognor-mod32/unsigned=>unsigned
 710              fast-lognor/unsigned=>unsigned)
 711   (:translate lognor-mod32))
 712
 713 (define-source-transform logeqv (&rest args)
 714   (if (oddp (length args))
 715       `(logxor ,@args)
 716       `(lognot (logxor ,@args))))
 717 (define-source-transform logandc1 (x y)
 718   `(logand (lognot ,x) ,y))
 719 (define-source-transform logandc2 (x y)
 720   `(logand ,x (lognot ,y)))
 721 (define-source-transform logorc1 (x y)
 722   `(logior (lognot ,x) ,y))
 723 (define-source-transform logorc2 (x y)
 724   `(logior ,x (lognot ,y)))
 725 (define-source-transform lognand (x y)
 726   `(lognot (logand ,x ,y)))
 727 ;;;; Bignum stuff.
 728
 729 (define-vop (bignum-length get-header-data)
 730   (:translate sb!bignum::%bignum-length)
 731   (:policy :fast-safe))
 732
 733 (define-vop (bignum-set-length set-header-data)
 734   (:translate sb!bignum::%bignum-set-length)
 735   (:policy :fast-safe))
 736
 737 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
 738   (unsigned-reg) unsigned-num sb!bignum::%bignum-ref)
 739
 740 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
 741   (unsigned-reg) unsigned-num sb!bignum::%bignum-set)
 742
 743 (define-vop (digit-0-or-plus)
 744   (:translate sb!bignum::%digit-0-or-plusp)
 745   (:policy :fast-safe)
 746   (:args (digit :scs (unsigned-reg)))
 747   (:arg-types unsigned-num)
 748   (:conditional)
 749   (:info target not-p)
 750   (:generator 2
 751     (if not-p
 752         (inst bltz digit target)
 753         (inst bgez digit target))
 754     (inst nop)))
 755
 756 (define-vop (add-w/carry)
 757   (:translate sb!bignum::%add-with-carry)
 758   (:policy :fast-safe)
 759   (:args (a :scs (unsigned-reg))
 760          (b :scs (unsigned-reg))
 761          (c :scs (any-reg)))
 762   (:arg-types unsigned-num unsigned-num positive-fixnum)
 763   (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
 764   (:results (result :scs (unsigned-reg))
 765             (carry :scs (unsigned-reg) :from :eval))
 766   (:result-types unsigned-num positive-fixnum)
 767   (:temporary (:scs (non-descriptor-reg)) temp)
 768   (:generator 5
 769     (let ((carry-in (gen-label))
 770           (done (gen-label)))
 771       (inst bne c carry-in)
 772       (inst addu res a b)
 773
 774       (inst b done)
 775       (inst sltu carry res b)
 776
 777       (emit-label carry-in)
 778       (inst addu res 1)
 779       (inst nor temp a zero-tn)
 780       (inst sltu carry b temp)
 781       (inst xor carry 1)
 782
 783       (emit-label done)
 784       (move result res))))
 785
 786 (define-vop (sub-w/borrow)
 787   (:translate sb!bignum::%subtract-with-borrow)
 788   (:policy :fast-safe)
 789   (:args (a :scs (unsigned-reg))
 790          (b :scs (unsigned-reg))
 791          (c :scs (any-reg)))
 792   (:arg-types unsigned-num unsigned-num positive-fixnum)
 793   (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
 794   (:results (result :scs (unsigned-reg))
 795             (borrow :scs (unsigned-reg) :from :eval))
 796   (:result-types unsigned-num positive-fixnum)
 797   (:generator 4
 798     (let ((no-borrow-in (gen-label))
 799           (done (gen-label)))
 800
 801       (inst bne c no-borrow-in)
 802       (inst subu res a b)
 803
 804       (inst subu res 1)
 805       (inst b done)
 806       (inst sltu borrow b a)
 807
 808       (emit-label no-borrow-in)
 809       (inst sltu borrow a b)
 810       (inst xor borrow 1)
 811
 812       (emit-label done)
 813       (move result res))))
 814
 815 (define-vop (bignum-mult-and-add-3-arg)
 816   (:translate sb!bignum::%multiply-and-add)
 817   (:policy :fast-safe)
 818   (:args (x :scs (unsigned-reg))
 819          (y :scs (unsigned-reg))
 820          (carry-in :scs (unsigned-reg) :to :save))
 821   (:arg-types unsigned-num unsigned-num unsigned-num)
 822   (:temporary (:scs (unsigned-reg) :from (:argument 1)) temp)
 823   (:results (hi :scs (unsigned-reg))
 824             (lo :scs (unsigned-reg)))
 825   (:result-types unsigned-num unsigned-num)
 826   (:generator 6
 827     (inst multu x y)
 828     (inst mflo temp)
 829     (inst addu lo temp carry-in)
 830     (inst sltu temp lo carry-in)
 831     (inst mfhi hi)
 832     (inst addu hi temp)))
 833
 834 (define-vop (bignum-mult-and-add-4-arg)
 835   (:translate sb!bignum::%multiply-and-add)
 836   (:policy :fast-safe)
 837   (:args (x :scs (unsigned-reg))
 838          (y :scs (unsigned-reg))
 839          (prev :scs (unsigned-reg))
 840          (carry-in :scs (unsigned-reg) :to :save))
 841   (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
 842   (:temporary (:scs (unsigned-reg) :from (:argument 2)) temp)
 843   (:results (hi :scs (unsigned-reg))
 844             (lo :scs (unsigned-reg)))
 845   (:result-types unsigned-num unsigned-num)
 846   (:generator 9
 847     (inst multu x y)
 848     (inst addu lo prev carry-in)
 849     (inst sltu temp lo carry-in)
 850     (inst mfhi hi)
 851     (inst addu hi temp)
 852     (inst mflo temp)
 853     (inst addu lo temp)
 854     (inst sltu temp lo temp)
 855     (inst addu hi temp)))
 856
 857 (define-vop (bignum-mult)
 858   (:translate sb!bignum::%multiply)
 859   (:policy :fast-safe)
 860   (:args (x :scs (unsigned-reg))
 861          (y :scs (unsigned-reg)))
 862   (:arg-types unsigned-num unsigned-num)
 863   (:results (hi :scs (unsigned-reg))
 864             (lo :scs (unsigned-reg)))
 865   (:result-types unsigned-num unsigned-num)
 866   (:generator 3
 867     (inst multu x y)
 868     (inst mflo lo)
 869     (inst mfhi hi)))
 870
 871 (define-vop (bignum-lognot lognot-mod32/unsigned=>unsigned)
 872   (:translate sb!bignum::%lognot))
 873
 874 (define-vop (fixnum-to-digit)
 875   (:translate sb!bignum::%fixnum-to-digit)
 876   (:policy :fast-safe)
 877   (:args (fixnum :scs (any-reg)))
 878   (:arg-types tagged-num)
 879   (:results (digit :scs (unsigned-reg)))
 880   (:result-types unsigned-num)
 881   (:generator 1
 882     (inst sra digit fixnum 2)))
 883
 884 (define-vop (bignum-floor)
 885   (:translate sb!bignum::%floor)
 886   (:policy :fast-safe)
 887   (:args (num-high :scs (unsigned-reg) :target rem)
 888          (num-low :scs (unsigned-reg) :target rem-low)
 889          (denom :scs (unsigned-reg) :to (:eval 1)))
 890   (:arg-types unsigned-num unsigned-num unsigned-num)
 891   (:temporary (:scs (unsigned-reg) :from (:argument 1)) rem-low)
 892   (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp)
 893   (:results (quo :scs (unsigned-reg) :from (:eval 0))
 894             (rem :scs (unsigned-reg) :from (:argument 0)))
 895   (:result-types unsigned-num unsigned-num)
 896   (:generator 325 ; number of inst assuming targeting works.
 897     (move rem num-high)
 898     (move rem-low num-low)
 899     (flet ((maybe-subtract (&optional (guess temp))
 900              (inst subu temp guess 1)
 901              (inst and temp denom)
 902              (inst subu rem temp)))
 903       (inst sltu quo rem denom)
 904       (maybe-subtract quo)
 905       (dotimes (i 32)
 906         (inst sll rem 1)
 907         (inst srl temp rem-low 31)
 908         (inst or rem temp)
 909         (inst sll rem-low 1)
 910         (inst sltu temp rem denom)
 911         (inst sll quo 1)
 912         (inst or quo temp)
 913         (maybe-subtract)))
 914     (inst nor quo zero-tn)))
 915
 916 (define-vop (signify-digit)
 917   (:translate sb!bignum::%fixnum-digit-with-correct-sign)
 918   (:policy :fast-safe)
 919   (:args (digit :scs (unsigned-reg) :target res))
 920   (:arg-types unsigned-num)
 921   (:results (res :scs (any-reg signed-reg)))
 922   (:result-types signed-num)
 923   (:generator 1
 924     (sc-case res
 925       (any-reg
 926        (inst sll res digit 2))
 927       (signed-reg
 928        (move res digit)))))
 929
 930
 931 (define-vop (digit-ashr)
 932   (:translate sb!bignum::%ashr)
 933   (:policy :fast-safe)
 934   (:args (digit :scs (unsigned-reg))
 935          (count :scs (unsigned-reg)))
 936   (:arg-types unsigned-num positive-fixnum)
 937   (:results (result :scs (unsigned-reg)))
 938   (:result-types unsigned-num)
 939   (:generator 1
 940     (inst sra result digit count)))
 941
 942 (define-vop (digit-lshr digit-ashr)
 943   (:translate sb!bignum::%digit-logical-shift-right)
 944   (:generator 1
 945     (inst srl result digit count)))
 946
 947 (define-vop (digit-ashl digit-ashr)
 948   (:translate sb!bignum::%ashl)
 949   (:generator 1
 950     (inst sll result digit count)))
 951
 952 \f
 953 ;;;; Static functions.
 954
 955 (define-static-fun two-arg-gcd (x y) :translate gcd)
 956 (define-static-fun two-arg-lcm (x y) :translate lcm)
 957
 958 (define-static-fun two-arg-+ (x y) :translate +)
 959 (define-static-fun two-arg-- (x y) :translate -)
 960 (define-static-fun two-arg-* (x y) :translate *)
 961 (define-static-fun two-arg-/ (x y) :translate /)
 962
 963 (define-static-fun two-arg-< (x y) :translate <)
 964 (define-static-fun two-arg-<= (x y) :translate <=)
 965 (define-static-fun two-arg-> (x y) :translate >)
 966 (define-static-fun two-arg->= (x y) :translate >=)
 967 (define-static-fun two-arg-= (x y) :translate =)
 968 (define-static-fun two-arg-/= (x y) :translate /=)
 969
 970 (define-static-fun %negate (x) :translate %negate)
 971
 972 (define-static-fun two-arg-and (x y) :translate logand)
 973 (define-static-fun two-arg-ior (x y) :translate logior)
 974 (define-static-fun two-arg-xor (x y) :translate logxor)