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