src/compiler/alpha/arith.lisp

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