src/compiler/alpha/arith.lisp

   1 ;;;; the VM definition arithmetic VOPs for the Alpha
   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 64) 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 subq zero-tn x res)))
  36
  37 (define-vop (fast-negate/signed signed-unop)
  38   (:translate %negate)
  39   (:generator 2
  40     (inst subq zero-tn x res)))
  41
  42 (define-vop (fast-lognot/fixnum fixnum-unop)
  43   (:translate lognot)
  44   (:generator 2
  45     (inst eqv x zero-tn res)))
  46
  47 (define-vop (fast-lognot/signed signed-unop)
  48   (:translate lognot)
  49   (:generator 1
  50     (inst not x res)))
  51 \f
  52 ;;;; binary fixnum operations
  53
  54 ;;; Assume that any constant operand is the second arg...
  55
  56 (define-vop (fast-fixnum-binop)
  57   (:args (x :target r :scs (any-reg))
  58          (y :target r :scs (any-reg)))
  59   (:arg-types tagged-num tagged-num)
  60   (:results (r :scs (any-reg)))
  61   (:result-types tagged-num)
  62   (:note "inline fixnum arithmetic")
  63   (:effects)
  64   (:affected)
  65   (:policy :fast-safe))
  66
  67 (define-vop (fast-unsigned-binop)
  68   (:args (x :target r :scs (unsigned-reg))
  69          (y :target r :scs (unsigned-reg)))
  70   (:arg-types unsigned-num unsigned-num)
  71   (:results (r :scs (unsigned-reg)))
  72   (:result-types unsigned-num)
  73   (:note "inline (unsigned-byte 64) arithmetic")
  74   (:effects)
  75   (:affected)
  76   (:policy :fast-safe))
  77
  78 (define-vop (fast-signed-binop)
  79   (:args (x :target r :scs (signed-reg))
  80          (y :target r :scs (signed-reg)))
  81   (:arg-types signed-num signed-num)
  82   (:results (r :scs (signed-reg)))
  83   (:result-types signed-num)
  84   (:note "inline (signed-byte 64) arithmetic")
  85   (:effects)
  86   (:affected)
  87   (:policy :fast-safe))
  88
  89 (define-vop (fast-fixnum-c-binop fast-fixnum-binop)
  90   (:args (x :target r :scs (any-reg)))
  91   (:info y)
  92   (:arg-types tagged-num (:constant integer)))
  93
  94 (define-vop (fast-signed-c-binop fast-signed-binop)
  95   (:args (x :target r :scs (signed-reg)))
  96   (:info y)
  97   (:arg-types tagged-num (:constant integer)))
  98
  99 (define-vop (fast-unsigned-c-binop fast-unsigned-binop)
 100   (:args (x :target r :scs (unsigned-reg)))
 101   (:info y)
 102   (:arg-types tagged-num (:constant integer)))
 103
 104 (defmacro define-binop (translate cost untagged-cost op
 105                                   tagged-type untagged-type)
 106   `(progn
 107      (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
 108                   fast-fixnum-binop)
 109        (:args (x :target r :scs (any-reg))
 110               (y :target r :scs (any-reg)))
 111        (:translate ,translate)
 112        (:generator ,(1+ cost)
 113          (inst ,op x y r)))
 114      (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
 115                   fast-signed-binop)
 116        (:args (x :target r :scs (signed-reg))
 117               (y :target r :scs (signed-reg)))
 118        (:translate ,translate)
 119        (:generator ,(1+ untagged-cost)
 120          (inst ,op x y r)))
 121      (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
 122                   fast-unsigned-binop)
 123        (:args (x :target r :scs (unsigned-reg))
 124               (y :target r :scs (unsigned-reg)))
 125        (:translate ,translate)
 126        (:generator ,(1+ untagged-cost)
 127          (inst ,op x y r)))
 128      ,@(when tagged-type
 129          `((define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
 130                         fast-fixnum-c-binop)
 131                        (:arg-types tagged-num (:constant ,tagged-type))
 132              (:translate ,translate)
 133              (:generator ,cost
 134                          (inst ,op x (fixnumize y) r)))))
 135      ,@(when untagged-type
 136          `((define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
 137                         fast-signed-c-binop)
 138                        (:arg-types signed-num (:constant ,untagged-type))
 139              (:translate ,translate)
 140              (:generator ,untagged-cost
 141                          (inst ,op x y r)))
 142            (define-vop (,(symbolicate "FAST-" translate
 143                                       "-C/UNSIGNED=>UNSIGNED")
 144                         fast-unsigned-c-binop)
 145                        (:arg-types unsigned-num (:constant ,untagged-type))
 146              (:translate ,translate)
 147              (:generator ,untagged-cost
 148                          (inst ,op x y r)))))))
 149
 150 (define-binop + 1 5 addq (unsigned-byte 6) (unsigned-byte 8))
 151 (define-binop - 1 5 subq (unsigned-byte 6) (unsigned-byte 8))
 152 (define-binop logior 1 3 bis (unsigned-byte 6) (unsigned-byte 8))
 153 (define-binop lognor 1 3 ornot (unsigned-byte 6) (unsigned-byte 8))
 154 (define-binop logand 1 3 and (unsigned-byte 6) (unsigned-byte 8))
 155 (define-binop logxor 1 3 xor (unsigned-byte 6) (unsigned-byte 8))
 156 \f
 157 ;;;; shifting
 158
 159 (define-vop (fast-ash/unsigned=>unsigned)
 160   (:note "inline ASH")
 161   (:args (number :scs (unsigned-reg) :to :save)
 162          (amount :scs (signed-reg)))
 163   (:arg-types unsigned-num signed-num)
 164   (:results (result :scs (unsigned-reg)))
 165   (:result-types unsigned-num)
 166   (:translate ash)
 167   (:policy :fast-safe)
 168   (:temporary (:sc non-descriptor-reg) ndesc)
 169   (:temporary (:sc non-descriptor-reg :to :eval) temp)
 170   (:generator 3
 171     (inst bge amount positive)
 172     (inst subq zero-tn amount ndesc)
 173     (inst cmplt ndesc 64 temp)
 174     (inst srl number ndesc result)
 175     ;; FIXME: this looks like a candidate for a conditional move --
 176     ;; CSR, 2003-09-10
 177     (inst bne temp done)
 178     (move zero-tn result)
 179     (inst br zero-tn done)
 180
 181     POSITIVE
 182     (inst sll number amount result)
 183
 184     DONE))
 185
 186 (define-vop (fast-ash/signed=>signed)
 187   (:note "inline ASH")
 188   (:args (number :scs (signed-reg) :to :save)
 189          (amount :scs (signed-reg)))
 190   (:arg-types signed-num signed-num)
 191   (:results (result :scs (signed-reg)))
 192   (:result-types signed-num)
 193   (:translate ash)
 194   (:policy :fast-safe)
 195   (:temporary (:sc non-descriptor-reg) ndesc)
 196   (:temporary (:sc non-descriptor-reg :to :eval) temp)
 197   (:generator 3
 198     (inst bge amount positive)
 199     (inst subq zero-tn amount ndesc)
 200     (inst cmplt ndesc 63 temp)
 201     (inst sra number ndesc result)
 202     (inst bne temp done)
 203     (inst sra number 63 result)
 204     (inst br zero-tn done)
 205
 206     POSITIVE
 207     (inst sll number amount result)
 208
 209     DONE))
 210
 211 (define-vop (fast-ash-c/signed=>signed)
 212   (:policy :fast-safe)
 213   (:translate ash)
 214   (:note nil)
 215   (:args (number :scs (signed-reg)))
 216   (:info count)
 217   (:arg-types signed-num (:constant integer))
 218   (:results (result :scs (signed-reg)))
 219   (:result-types signed-num)
 220   (:generator 1
 221     (cond
 222       ((< count 0) (inst sra number (- count) result))
 223       ((> count 0) (inst sll number count result))
 224       (t (bug "identity ASH not transformed away")))))
 225
 226 (define-vop (fast-ash-c/unsigned=>unsigned)
 227   (:policy :fast-safe)
 228   (:translate ash)
 229   (:note nil)
 230   (:args (number :scs (unsigned-reg)))
 231   (:info count)
 232   (:arg-types unsigned-num (:constant integer))
 233   (:results (result :scs (unsigned-reg)))
 234   (:result-types unsigned-num)
 235   (:generator 1
 236     (cond
 237       ((< count -63) (move zero-tn result))
 238       ((< count 0) (inst sra number (- count) result))
 239       ((> count 0) (inst sll number count result))
 240       (t (bug "identity ASH not transformed away")))))
 241
 242 (define-vop (signed-byte-64-len)
 243   (:translate integer-length)
 244   (:note "inline (signed-byte 64) integer-length")
 245   (:policy :fast-safe)
 246   (:args (arg :scs (signed-reg) :to (:argument 1)))
 247   (:arg-types signed-num)
 248   (:results (res :scs (any-reg)))
 249   (:result-types positive-fixnum)
 250   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
 251   (:generator 30
 252     (inst not arg shift)
 253     (inst cmovge arg arg shift)
 254     (inst subq zero-tn (fixnumize 1) res)
 255     (inst sll shift 1 shift)
 256     LOOP
 257     (inst addq res (fixnumize 1) res)
 258     (inst srl shift 1 shift)
 259     (inst bne shift loop)))
 260
 261 (define-vop (unsigned-byte-64-count)
 262   (:translate logcount)
 263   (:note "inline (unsigned-byte 64) logcount")
 264   (:policy :fast-safe)
 265   (:args (arg :scs (unsigned-reg) :target num))
 266   (:arg-types unsigned-num)
 267   (:results (res :scs (unsigned-reg)))
 268   (:result-types positive-fixnum)
 269   (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0)
 270                     :target res) num)
 271   (:temporary (:scs (non-descriptor-reg)) mask temp)
 272   (:generator 60
 273     ;; FIXME: now this looks expensive, what with these 64bit loads.
 274     ;; Maybe a loop and count would be faster?  -- CSR, 2003-09-10
 275     (inst li #x5555555555555555 mask)
 276     (inst srl arg 1 temp)
 277     (inst and arg mask num)
 278     (inst and temp mask temp)
 279     (inst addq num temp num)
 280     (inst li #x3333333333333333 mask)
 281     (inst srl num 2 temp)
 282     (inst and num mask num)
 283     (inst and temp mask temp)
 284     (inst addq num temp num)
 285     (inst li #x0f0f0f0f0f0f0f0f mask)
 286     (inst srl num 4 temp)
 287     (inst and num mask num)
 288     (inst and temp mask temp)
 289     (inst addq num temp num)
 290     (inst li #x00ff00ff00ff00ff mask)
 291     (inst srl num 8 temp)
 292     (inst and num mask num)
 293     (inst and temp mask temp)
 294     (inst addq num temp num)
 295     (inst li #x0000ffff0000ffff mask)
 296     (inst srl num 16 temp)
 297     (inst and num mask num)
 298     (inst and temp mask temp)
 299     (inst addq num temp num)
 300     (inst li #x00000000ffffffff mask)
 301     (inst srl num 32 temp)
 302     (inst and num mask num)
 303     (inst and temp mask temp)
 304     (inst addq num temp res)))
 305 \f
 306 ;;;; multiplying
 307
 308 (define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
 309   (:temporary (:scs (non-descriptor-reg)) temp)
 310   (:translate *)
 311   (:generator 4
 312     (inst sra y 2 temp)
 313     (inst mulq x temp r)))
 314
 315 (define-vop (fast-*/signed=>signed fast-signed-binop)
 316   (:translate *)
 317   (:generator 3
 318     (inst mulq x y r)))
 319
 320 (define-vop (fast-*/unsigned=>unsigned fast-unsigned-binop)
 321   (:translate *)
 322   (:generator 3
 323     (inst mulq x y r)))
 324 \f
 325 ;;;; binary conditional VOPs
 326
 327 (define-vop (fast-conditional)
 328   (:conditional)
 329   (:info target not-p)
 330   (:effects)
 331   (:affected)
 332   (:temporary (:scs (non-descriptor-reg)) temp)
 333   (:policy :fast-safe))
 334
 335 (define-vop (fast-conditional/fixnum fast-conditional)
 336   (:args (x :scs (any-reg))
 337          (y :scs (any-reg)))
 338   (:arg-types tagged-num tagged-num)
 339   (:note "inline fixnum comparison"))
 340
 341 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
 342   (:args (x :scs (any-reg)))
 343   (:arg-types tagged-num (:constant (unsigned-byte-with-a-bite-out 6 4)))
 344   (:info target not-p y))
 345
 346 (define-vop (fast-conditional/signed fast-conditional)
 347   (:args (x :scs (signed-reg))
 348          (y :scs (signed-reg)))
 349   (:arg-types signed-num signed-num)
 350   (:note "inline (signed-byte 64) comparison"))
 351
 352 (define-vop (fast-conditional-c/signed fast-conditional/signed)
 353   (:args (x :scs (signed-reg)))
 354   (:arg-types signed-num (:constant (unsigned-byte-with-a-bite-out 8 1)))
 355   (:info target not-p y))
 356
 357 (define-vop (fast-conditional/unsigned fast-conditional)
 358   (:args (x :scs (unsigned-reg))
 359          (y :scs (unsigned-reg)))
 360   (:arg-types unsigned-num unsigned-num)
 361   (:note "inline (unsigned-byte 64) comparison"))
 362
 363 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
 364   (:args (x :scs (unsigned-reg)))
 365   (:arg-types unsigned-num (:constant (unsigned-byte-with-a-bite-out 8 1)))
 366   (:info target not-p y))
 367
 368
 369 (defmacro define-conditional-vop (translate &rest generator)
 370   `(progn
 371      ,@(mapcar (lambda (suffix cost signed)
 372                  (unless (and (member suffix '(/fixnum -c/fixnum))
 373                               (eq translate 'eql))
 374                    `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
 375                                                   translate suffix))
 376                                  ,(intern
 377                                    (format nil "~:@(FAST-CONDITIONAL~A~)"
 378                                            suffix)))
 379                       (:translate ,translate)
 380                       (:generator ,cost
 381                                   (let* ((signed ,signed)
 382                                          (-c/fixnum ,(eq suffix '-c/fixnum))
 383                                          (y (if -c/fixnum (fixnumize y) y)))
 384                                     ,@generator)))))
 385                '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
 386                '(3 2 5 4 5 4)
 387                '(t t t t nil nil))))
 388
 389 (define-conditional-vop <
 390   (cond ((and signed (eql y 0))
 391          (if not-p
 392              (inst bge x target)
 393              (inst blt x target)))
 394         (t
 395          (if signed
 396              (inst cmplt x y temp)
 397              (inst cmpult x y temp))
 398          (if not-p
 399              (inst beq temp target)
 400              (inst bne temp target)))))
 401
 402 (define-conditional-vop >
 403   (cond ((and signed (eql y 0))
 404          (if not-p
 405              (inst ble x target)
 406              (inst bgt x target)))
 407         ((integerp y)
 408          (let ((y (+ y (if -c/fixnum (fixnumize 1) 1))))
 409            (if signed
 410                (inst cmplt x y temp)
 411                (inst cmpult x y temp))
 412            (if not-p
 413                (inst bne temp target)
 414                (inst beq temp target))))
 415         (t
 416          (if signed
 417              (inst cmplt y x temp)
 418              (inst cmpult y x temp))
 419          (if not-p
 420              (inst beq temp target)
 421              (inst bne temp target)))))
 422
 423 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not
 424 ;;; just a known fixnum.
 425
 426 (define-conditional-vop eql
 427   (declare (ignore signed))
 428   (when (integerp y)
 429     (inst li y temp)
 430     (setf y temp))
 431   (inst cmpeq x y temp)
 432   (if not-p
 433       (inst beq temp target)
 434       (inst bne temp target)))
 435
 436 ;;; These versions specify a fixnum restriction on their first arg. We
 437 ;;; have also generic-eql/fixnum VOPs which are the same, but have no
 438 ;;; restriction on the first arg and a higher cost. The reason for
 439 ;;; doing this is to prevent fixnum specific operations from being
 440 ;;; used on word integers, spuriously consing the argument.
 441 (define-vop (fast-eql/fixnum fast-conditional)
 442   (:args (x :scs (any-reg))
 443          (y :scs (any-reg)))
 444   (:arg-types tagged-num tagged-num)
 445   (:note "inline fixnum comparison")
 446   (:translate eql)
 447   (:generator 3
 448     (cond ((equal y zero-tn)
 449            (if not-p
 450                (inst bne x target)
 451                (inst beq x target)))
 452           (t
 453            (inst cmpeq x y temp)
 454            (if not-p
 455                (inst beq temp target)
 456                (inst bne temp target))))))
 457
 458 ;;;
 459 (define-vop (generic-eql/fixnum fast-eql/fixnum)
 460   (:args (x :scs (any-reg descriptor-reg))
 461          (y :scs (any-reg)))
 462   (:arg-types * tagged-num)
 463   (:variant-cost 7))
 464
 465 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
 466   (:args (x :scs (any-reg)))
 467   (:arg-types tagged-num (:constant (signed-byte 6)))
 468   (:temporary (:scs (non-descriptor-reg)) temp)
 469   (:info target not-p y)
 470   (:translate eql)
 471   (:generator 2
 472     (let ((y (cond ((eql y 0) zero-tn)
 473                    (t
 474                     (inst li (fixnumize y) temp)
 475                     temp))))
 476       (inst cmpeq x y temp)
 477       (if not-p
 478           (inst beq temp target)
 479           (inst bne temp target)))))
 480 ;;;
 481 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
 482   (:args (x :scs (any-reg descriptor-reg)))
 483   (:arg-types * (:constant (signed-byte 6)))
 484   (:variant-cost 6))
 485
 486 \f
 487 ;;;; 32-bit logical operations
 488
 489 (define-vop (merge-bits)
 490   (:translate merge-bits)
 491   (:args (shift :scs (signed-reg unsigned-reg))
 492          (prev :scs (unsigned-reg))
 493          (next :scs (unsigned-reg)))
 494   (:arg-types tagged-num unsigned-num unsigned-num)
 495   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 496   (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
 497   (:results (result :scs (unsigned-reg)))
 498   (:result-types unsigned-num)
 499   (:policy :fast-safe)
 500   (:generator 4
 501     (let ((done (gen-label)))
 502       (inst srl next shift res)
 503       (inst beq shift done)
 504       (inst subq zero-tn shift temp)
 505       (inst sll prev temp temp)
 506       (inst bis res temp res)
 507       (emit-label done)
 508       (move res result))))
 509
 510
 511 (define-vop (32bit-logical)
 512   (:args (x :scs (unsigned-reg))
 513          (y :scs (unsigned-reg)))
 514   (:arg-types unsigned-num unsigned-num)
 515   (:results (r :scs (unsigned-reg)))
 516   (:result-types unsigned-num)
 517   (:policy :fast-safe))
 518
 519 (define-vop (32bit-logical-not 32bit-logical)
 520   (:translate 32bit-logical-not)
 521   (:args (x :scs (unsigned-reg)))
 522   (:arg-types unsigned-num)
 523   (:generator 2
 524     (inst not x r)
 525     (inst mskll r 4 r)))
 526
 527 (define-vop (32bit-logical-and 32bit-logical)
 528   (:translate 32bit-logical-and)
 529   (:generator 1
 530     (inst and x y r)))
 531
 532 (deftransform 32bit-logical-nand ((x y) (* *))
 533   '(32bit-logical-not (32bit-logical-and x y)))
 534
 535 (define-vop (32bit-logical-or 32bit-logical)
 536   (:translate 32bit-logical-or)
 537   (:generator 1
 538     (inst bis x y r)))
 539
 540 (define-vop (32bit-logical-nor 32bit-logical)
 541   (:translate 32bit-logical-nor)
 542   (:generator 2
 543     (inst ornot x y r)
 544     (inst mskll r 4 r)))
 545
 546 (define-vop (32bit-logical-xor 32bit-logical)
 547   (:translate 32bit-logical-xor)
 548   (:generator 1
 549     (inst xor x y r)))
 550
 551 (deftransform 32bit-logical-eqv ((x y) (* *))
 552   '(32bit-logical-not (32bit-logical-xor x y)))
 553
 554 (deftransform 32bit-logical-andc1 ((x y) (* *))
 555   '(32bit-logical-and (32bit-logical-not x) y))
 556
 557 (deftransform 32bit-logical-andc2 ((x y) (* *))
 558   '(32bit-logical-and x (32bit-logical-not y)))
 559
 560 (deftransform 32bit-logical-orc1 ((x y) (* *))
 561   '(32bit-logical-or (32bit-logical-not x) y))
 562
 563 (deftransform 32bit-logical-orc2 ((x y) (* *))
 564   '(32bit-logical-or x (32bit-logical-not y)))
 565
 566
 567 (define-vop (shift-towards-someplace)
 568   (:policy :fast-safe)
 569   (:args (num :scs (unsigned-reg))
 570          (amount :scs (signed-reg)))
 571   (:arg-types unsigned-num tagged-num)
 572   (:results (r :scs (unsigned-reg)))
 573   (:result-types unsigned-num))
 574
 575 (define-vop (shift-towards-start shift-towards-someplace)
 576   (:translate shift-towards-start)
 577   (:note "SHIFT-TOWARDS-START")
 578   (:temporary (:sc non-descriptor-reg) temp)
 579   (:generator 1
 580     (inst and amount #x1f temp)
 581     (inst srl num temp r)))
 582
 583 (define-vop (shift-towards-end shift-towards-someplace)
 584   (:translate shift-towards-end)
 585   (:note "SHIFT-TOWARDS-END")
 586   (:temporary (:sc non-descriptor-reg) temp)
 587   (:generator 1
 588     (inst and amount #x1f temp)
 589     (inst sll num temp r)))
 590 \f
 591 ;;;; bignum stuff
 592
 593 (define-vop (bignum-length get-header-data)
 594   (:translate sb!bignum::%bignum-length)
 595   (:policy :fast-safe))
 596
 597 (define-vop (bignum-set-length set-header-data)
 598   (:translate sb!bignum::%bignum-set-length)
 599   (:policy :fast-safe))
 600
 601 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
 602   (unsigned-reg) unsigned-num sb!bignum::%bignum-ref)
 603
 604 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
 605   (unsigned-reg) unsigned-num sb!bignum::%bignum-set #!+gengc nil)
 606
 607 (define-vop (digit-0-or-plus)
 608   (:translate sb!bignum::%digit-0-or-plusp)
 609   (:policy :fast-safe)
 610   (:args (digit :scs (unsigned-reg)))
 611   (:arg-types unsigned-num)
 612   (:temporary (:sc non-descriptor-reg) temp)
 613   (:conditional)
 614   (:info target not-p)
 615   (:generator 2
 616     (inst sll digit 32 temp)
 617     (if not-p
 618         (inst blt temp target)
 619         (inst bge temp target))))
 620
 621 (define-vop (add-w/carry)
 622   (:translate sb!bignum::%add-with-carry)
 623   (:policy :fast-safe)
 624   (:args (a :scs (unsigned-reg))
 625          (b :scs (unsigned-reg))
 626          (c :scs (unsigned-reg)))
 627   (:arg-types unsigned-num unsigned-num positive-fixnum)
 628   (:results (result :scs (unsigned-reg) :from :load)
 629             (carry :scs (unsigned-reg) :from :eval))
 630   (:result-types unsigned-num positive-fixnum)
 631   (:generator 5
 632     (inst addq a b result)
 633     (inst addq result c result)
 634     (inst sra result 32 carry)
 635     (inst mskll result 4 result)))
 636
 637 (define-vop (sub-w/borrow)
 638   (:translate sb!bignum::%subtract-with-borrow)
 639   (:policy :fast-safe)
 640   (:args (a :scs (unsigned-reg))
 641          (b :scs (unsigned-reg))
 642          (c :scs (unsigned-reg)))
 643   (:arg-types unsigned-num unsigned-num positive-fixnum)
 644   (:results (result :scs (unsigned-reg) :from :load)
 645             (borrow :scs (unsigned-reg) :from :eval))
 646   (:result-types unsigned-num positive-fixnum)
 647   (:generator 4
 648     (inst xor c 1 result)
 649     (inst subq a result result)
 650     (inst subq result b result)
 651     (inst srl result 63 borrow)
 652     (inst xor borrow 1 borrow)
 653     (inst mskll result 4 result)))
 654
 655 (define-vop (bignum-mult-and-add-3-arg)
 656   (:translate sb!bignum::%multiply-and-add)
 657   (:policy :fast-safe)
 658   (:args (x :scs (unsigned-reg))
 659          (y :scs (unsigned-reg))
 660          (carry-in :scs (unsigned-reg) :to :save))
 661   (:arg-types unsigned-num unsigned-num unsigned-num)
 662   (:results (hi :scs (unsigned-reg))
 663             (lo :scs (unsigned-reg)))
 664   (:result-types unsigned-num unsigned-num)
 665   (:generator 6
 666     (inst mulq x y lo)
 667     (inst addq lo carry-in lo)
 668     (inst srl lo 32 hi)
 669     (inst mskll lo 4 lo)))
 670
 671
 672 (define-vop (bignum-mult-and-add-4-arg)
 673   (:translate sb!bignum::%multiply-and-add)
 674   (:policy :fast-safe)
 675   (:args (x :scs (unsigned-reg))
 676          (y :scs (unsigned-reg))
 677          (prev :scs (unsigned-reg))
 678          (carry-in :scs (unsigned-reg) :to :save))
 679   (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
 680   (:results (hi :scs (unsigned-reg))
 681             (lo :scs (unsigned-reg)))
 682   (:result-types unsigned-num unsigned-num)
 683   (:generator 9
 684     (inst mulq x y lo)
 685     (inst addq lo prev lo)
 686     (inst addq lo carry-in lo)
 687     (inst srl lo 32 hi)
 688     (inst mskll lo 4 lo)))
 689
 690 (define-vop (bignum-mult)
 691   (:translate sb!bignum::%multiply)
 692   (:policy :fast-safe)
 693   (:args (x :scs (unsigned-reg))
 694          (y :scs (unsigned-reg)))
 695   (:arg-types unsigned-num unsigned-num)
 696   (:results (hi :scs (unsigned-reg))
 697             (lo :scs (unsigned-reg)))
 698   (:result-types unsigned-num unsigned-num)
 699   (:generator 3
 700     (inst mulq x y lo)
 701     (inst srl lo 32 hi)
 702     (inst mskll lo 4 lo)))
 703
 704 (define-vop (bignum-lognot)
 705   (:translate sb!bignum::%lognot)
 706   (:policy :fast-safe)
 707   (:args (x :scs (unsigned-reg)))
 708   (:arg-types unsigned-num)
 709   (:results (r :scs (unsigned-reg)))
 710   (:result-types unsigned-num)
 711   (:generator 1
 712     (inst not x r)
 713     (inst mskll r 4 r)))
 714
 715 (define-vop (fixnum-to-digit)
 716   (:translate sb!bignum::%fixnum-to-digit)
 717   (:policy :fast-safe)
 718   (:args (fixnum :scs (any-reg)))
 719   (:arg-types tagged-num)
 720   (:results (digit :scs (unsigned-reg)))
 721   (:result-types unsigned-num)
 722   (:generator 1
 723     (inst sra fixnum 2 digit)))
 724
 725 (define-vop (bignum-floor)
 726   (:translate sb!bignum::%floor)
 727   (:policy :fast-safe)
 728   (:args (num-high :scs (unsigned-reg))
 729          (num-low :scs (unsigned-reg))
 730          (denom-arg :scs (unsigned-reg) :target denom))
 731   (:arg-types unsigned-num unsigned-num unsigned-num)
 732   (:temporary (:scs (unsigned-reg) :from (:argument 2)) denom)
 733   (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp)
 734   (:results (quo :scs (unsigned-reg) :from (:eval 0))
 735             (rem :scs (unsigned-reg) :from (:argument 0)))
 736   (:result-types unsigned-num unsigned-num)
 737   (:generator 325 ; number of inst assuming targeting works.
 738     (inst sll num-high 32 rem)
 739     (inst bis rem num-low rem)
 740     (inst sll denom-arg 32 denom)
 741     (inst cmpule denom rem quo)
 742     (inst beq quo shift1)
 743     (inst subq rem denom rem)
 744     SHIFT1
 745     (dotimes (i 32)
 746       (let ((shift2 (gen-label)))
 747         (inst srl denom 1 denom)
 748         (inst cmpule denom rem temp)
 749         (inst sll quo 1 quo)
 750         (inst beq temp shift2)
 751         (inst subq rem denom rem)
 752         (inst bis quo 1 quo)
 753         (emit-label shift2)))))
 754
 755 (define-vop (signify-digit)
 756   (:translate sb!bignum::%fixnum-digit-with-correct-sign)
 757   (:policy :fast-safe)
 758   (:args (digit :scs (unsigned-reg) :target res))
 759   (:arg-types unsigned-num)
 760   (:results (res :scs (any-reg signed-reg)))
 761   (:result-types signed-num)
 762   (:generator 2
 763     (sc-case res
 764       (any-reg
 765        (inst sll digit 34 res)
 766        (inst sra res 32 res))
 767       (signed-reg
 768        (inst sll digit 32 res)
 769        (inst sra res 32 res)))))
 770
 771
 772 (define-vop (digit-ashr)
 773   (:translate sb!bignum::%ashr)
 774   (:policy :fast-safe)
 775   (:args (digit :scs (unsigned-reg))
 776          (count :scs (unsigned-reg)))
 777   (:arg-types unsigned-num positive-fixnum)
 778   (:results (result :scs (unsigned-reg) :from (:argument 0)))
 779   (:result-types unsigned-num)
 780   (:generator 1
 781     (inst sll digit 32 result)
 782     (inst sra result count result)
 783     (inst srl result 32 result)))
 784
 785 (define-vop (digit-lshr digit-ashr)
 786   (:translate sb!bignum::%digit-logical-shift-right)
 787   (:generator 1
 788     (inst srl digit count result)))
 789
 790 (define-vop (digit-ashl digit-ashr)
 791   (:translate sb!bignum::%ashl)
 792   (:generator 1
 793     (inst sll digit count result)))
 794 \f
 795 ;;;; static functions
 796
 797 (define-static-fun two-arg-gcd (x y) :translate gcd)
 798 (define-static-fun two-arg-lcm (x y) :translate lcm)
 799
 800 (define-static-fun two-arg-+ (x y) :translate +)
 801 (define-static-fun two-arg-- (x y) :translate -)
 802 (define-static-fun two-arg-* (x y) :translate *)
 803 (define-static-fun two-arg-/ (x y) :translate /)
 804
 805 (define-static-fun two-arg-< (x y) :translate <)
 806 (define-static-fun two-arg-<= (x y) :translate <=)
 807 (define-static-fun two-arg-> (x y) :translate >)
 808 (define-static-fun two-arg->= (x y) :translate >=)
 809 (define-static-fun two-arg-= (x y) :translate =)
 810 (define-static-fun two-arg-/= (x y) :translate /=)
 811
 812 (define-static-fun %negate (x) :translate %negate)
 813
 814 (define-static-fun two-arg-and (x y) :translate logand)
 815 (define-static-fun two-arg-ior (x y) :translate logior)
 816 (define-static-fun two-arg-xor (x y) :translate logxor)