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