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