src/compiler/x86-64/arith.lisp

   1 ;;;; the VM definition of arithmetic VOPs for the x86-64
   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 (fast-safe-arith-op)
  17   (:policy :fast-safe)
  18   (:effects)
  19   (:affected))
  20
  21 (define-vop (fixnum-unop fast-safe-arith-op)
  22   (:args (x :scs (any-reg) :target res))
  23   (:results (res :scs (any-reg)))
  24   (:note "inline fixnum arithmetic")
  25   (:arg-types tagged-num)
  26   (:result-types tagged-num))
  27
  28 (define-vop (signed-unop fast-safe-arith-op)
  29   (:args (x :scs (signed-reg) :target res))
  30   (:results (res :scs (signed-reg)))
  31   (:note "inline (signed-byte 64) arithmetic")
  32   (:arg-types signed-num)
  33   (:result-types signed-num))
  34
  35 (define-vop (fast-negate/fixnum fixnum-unop)
  36   (:translate %negate)
  37   (:generator 1
  38     (move res x)
  39     (inst neg res)))
  40
  41 (define-vop (fast-negate/signed signed-unop)
  42   (:translate %negate)
  43   (:generator 2
  44     (move res x)
  45     (inst neg res)))
  46
  47 (define-vop (fast-lognot/fixnum fixnum-unop)
  48   (:translate lognot)
  49   (:generator 1
  50     (move res x)
  51     (inst xor res (fixnumize -1))))
  52
  53 (define-vop (fast-lognot/signed signed-unop)
  54   (:translate lognot)
  55   (:generator 2
  56     (move res x)
  57     (inst not res)))
  58 \f
  59 ;;;; binary fixnum operations
  60
  61 ;;; Assume that any constant operand is the second arg...
  62
  63 (define-vop (fast-fixnum-binop fast-safe-arith-op)
  64   (:args (x :target r :scs (any-reg)
  65             :load-if (not (and (sc-is x control-stack)
  66                                (sc-is y any-reg)
  67                                (sc-is r control-stack)
  68                                (location= x r))))
  69          (y :scs (any-reg control-stack)))
  70   (:arg-types tagged-num tagged-num)
  71   (:results (r :scs (any-reg) :from (:argument 0)
  72                :load-if (not (and (sc-is x control-stack)
  73                                   (sc-is y any-reg)
  74                                   (sc-is r control-stack)
  75                                   (location= x r)))))
  76   (:result-types tagged-num)
  77   (:note "inline fixnum arithmetic"))
  78
  79 (define-vop (fast-unsigned-binop fast-safe-arith-op)
  80   (:args (x :target r :scs (unsigned-reg)
  81             :load-if (not (and (sc-is x unsigned-stack)
  82                                (sc-is y unsigned-reg)
  83                                (sc-is r unsigned-stack)
  84                                (location= x r))))
  85          (y :scs (unsigned-reg unsigned-stack)))
  86   (:arg-types unsigned-num unsigned-num)
  87   (:results (r :scs (unsigned-reg) :from (:argument 0)
  88             :load-if (not (and (sc-is x unsigned-stack)
  89                                (sc-is y unsigned-reg)
  90                                (sc-is r unsigned-stack)
  91                                (location= x r)))))
  92   (:result-types unsigned-num)
  93   (:note "inline (unsigned-byte 64) arithmetic"))
  94
  95 (define-vop (fast-signed-binop fast-safe-arith-op)
  96   (:args (x :target r :scs (signed-reg)
  97             :load-if (not (and (sc-is x signed-stack)
  98                                (sc-is y signed-reg)
  99                                (sc-is r signed-stack)
 100                                (location= x r))))
 101          (y :scs (signed-reg signed-stack)))
 102   (:arg-types signed-num signed-num)
 103   (:results (r :scs (signed-reg) :from (:argument 0)
 104             :load-if (not (and (sc-is x signed-stack)
 105                                (sc-is y signed-reg)
 106                                (sc-is r signed-stack)
 107                                (location= x r)))))
 108   (:result-types signed-num)
 109   (:note "inline (signed-byte 64) arithmetic"))
 110
 111 (define-vop (fast-fixnum-binop-c fast-safe-arith-op)
 112   (:args (x :target r :scs (any-reg)
 113             :load-if (or (not (typep y '(signed-byte 29)))
 114                          (not (sc-is x any-reg control-stack)))))
 115   (:info y)
 116   (:arg-types tagged-num (:constant fixnum))
 117   (:results (r :scs (any-reg)
 118                :load-if (or (not (location= x r))
 119                             (not (typep y '(signed-byte 29))))))
 120   (:result-types tagged-num)
 121   (:note "inline fixnum arithmetic"))
 122
 123 (define-vop (fast-unsigned-binop-c fast-safe-arith-op)
 124   (:args (x :target r :scs (unsigned-reg)
 125             :load-if (or (not (typep y '(unsigned-byte 31)))
 126                          (not (sc-is x unsigned-reg unsigned-stack)))))
 127   (:info y)
 128   (:arg-types unsigned-num (:constant (unsigned-byte 64)))
 129   (:results (r :scs (unsigned-reg)
 130                :load-if (or (not (location= x r))
 131                             (not (typep y '(unsigned-byte 31))))))
 132   (:result-types unsigned-num)
 133   (:note "inline (unsigned-byte 64) arithmetic"))
 134
 135 (define-vop (fast-signed-binop-c fast-safe-arith-op)
 136   (:args (x :target r :scs (signed-reg)
 137             :load-if (or (not (typep y '(signed-byte 32)))
 138                          (not (sc-is x signed-reg signed-stack)))))
 139   (:info y)
 140   (:arg-types signed-num (:constant (signed-byte 64)))
 141   (:results (r :scs (signed-reg)
 142                :load-if (or (not (location= x r))
 143                             (not (typep y '(signed-byte 32))))))
 144   (:result-types signed-num)
 145   (:note "inline (signed-byte 64) arithmetic"))
 146
 147 (macrolet ((define-binop (translate untagged-penalty op)
 148              `(progn
 149                 (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
 150                              fast-fixnum-binop)
 151                   (:translate ,translate)
 152                   (:generator 2
 153                               (move r x)
 154                               (inst ,op r y)))
 155                 (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
 156                              fast-fixnum-binop-c)
 157                   (:translate ,translate)
 158                   (:generator 1
 159                   (move r x)
 160                   (inst ,op r (if (typep y '(signed-byte 29))
 161                                   (fixnumize y)
 162                                   (register-inline-constant :qword (fixnumize y))))))
 163                 (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
 164                              fast-signed-binop)
 165                   (:translate ,translate)
 166                   (:generator ,(1+ untagged-penalty)
 167                   (move r x)
 168                   (inst ,op r y)))
 169                 (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
 170                              fast-signed-binop-c)
 171                   (:translate ,translate)
 172                   (:generator ,untagged-penalty
 173                   (move r x)
 174                   (inst ,op r (if (typep y '(signed-byte 32))
 175                                   y
 176                                   (register-inline-constant :qword y)))))
 177                 (define-vop (,(symbolicate "FAST-"
 178                                            translate
 179                                            "/UNSIGNED=>UNSIGNED")
 180                 fast-unsigned-binop)
 181                   (:translate ,translate)
 182                   (:generator ,(1+ untagged-penalty)
 183                   (move r x)
 184                   (inst ,op r y)))
 185                 (define-vop (,(symbolicate 'fast-
 186                                            translate
 187                                            '-c/unsigned=>unsigned)
 188                              fast-unsigned-binop-c)
 189                   (:translate ,translate)
 190                   (:generator ,untagged-penalty
 191                   (move r x)
 192                   (inst ,op r (if (typep y '(unsigned-byte 31))
 193                                   y
 194                                   (register-inline-constant :qword y))))))))
 195
 196   ;;(define-binop + 4 add)
 197   (define-binop - 4 sub)
 198   (define-binop logand 2 and)
 199   (define-binop logior 2 or)
 200   (define-binop logxor 2 xor))
 201
 202 ;;; Special handling of add on the x86; can use lea to avoid a
 203 ;;; register load, otherwise it uses add.
 204 (define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op)
 205   (:translate +)
 206   (:args (x :scs (any-reg) :target r
 207             :load-if (not (and (sc-is x control-stack)
 208                                (sc-is y any-reg)
 209                                (sc-is r control-stack)
 210                                (location= x r))))
 211          (y :scs (any-reg control-stack)))
 212   (:arg-types tagged-num tagged-num)
 213   (:results (r :scs (any-reg) :from (:argument 0)
 214                :load-if (not (and (sc-is x control-stack)
 215                                   (sc-is y any-reg)
 216                                   (sc-is r control-stack)
 217                                   (location= x r)))))
 218   (:result-types tagged-num)
 219   (:note "inline fixnum arithmetic")
 220   (:generator 2
 221     (cond ((and (sc-is x any-reg) (sc-is y any-reg) (sc-is r any-reg)
 222                 (not (location= x r)))
 223            (inst lea r (make-ea :qword :base x :index y :scale 1)))
 224           (t
 225            (move r x)
 226            (inst add r y)))))
 227
 228 (define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op)
 229   (:translate +)
 230   (:args (x :target r :scs (any-reg)
 231             :load-if (or (not (typep y '(signed-byte 29)))
 232                          (not (sc-is x any-reg control-stack)))))
 233   (:info y)
 234   (:arg-types tagged-num (:constant fixnum))
 235   (:results (r :scs (any-reg)
 236                :load-if (or (not (location= x r))
 237                             (not (typep y '(signed-byte 29))))))
 238   (:result-types tagged-num)
 239   (:note "inline fixnum arithmetic")
 240   (:generator 1
 241     (cond ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r))
 242                 (typep y '(signed-byte 29)))
 243            (inst lea r (make-ea :qword :base x :disp (fixnumize y))))
 244           ((typep y '(signed-byte 29))
 245            (move r x)
 246            (inst add r (fixnumize y)))
 247           (t
 248            (move r x)
 249            (inst add r (register-inline-constant :qword (fixnumize y)))))))
 250
 251 (define-vop (fast-+/signed=>signed fast-safe-arith-op)
 252   (:translate +)
 253   (:args (x :scs (signed-reg) :target r
 254             :load-if (not (and (sc-is x signed-stack)
 255                                (sc-is y signed-reg)
 256                                (sc-is r signed-stack)
 257                                (location= x r))))
 258          (y :scs (signed-reg signed-stack)))
 259   (:arg-types signed-num signed-num)
 260   (:results (r :scs (signed-reg) :from (:argument 0)
 261                :load-if (not (and (sc-is x signed-stack)
 262                                   (sc-is y signed-reg)
 263                                   (location= x r)))))
 264   (:result-types signed-num)
 265   (:note "inline (signed-byte 64) arithmetic")
 266   (:generator 5
 267     (cond ((and (sc-is x signed-reg) (sc-is y signed-reg) (sc-is r signed-reg)
 268                 (not (location= x r)))
 269            (inst lea r (make-ea :qword :base x :index y :scale 1)))
 270           (t
 271            (move r x)
 272            (inst add r y)))))
 273
 274
 275 ;;;; Special logand cases: (logand signed unsigned) => unsigned
 276
 277 (define-vop (fast-logand/signed-unsigned=>unsigned
 278              fast-logand/unsigned=>unsigned)
 279   (:args (x :target r :scs (signed-reg)
 280             :load-if (not (and (sc-is x signed-stack)
 281                                (sc-is y unsigned-reg)
 282                                (sc-is r unsigned-stack)
 283                                (location= x r))))
 284          (y :scs (unsigned-reg unsigned-stack)))
 285   (:arg-types signed-num unsigned-num))
 286
 287 (define-vop (fast-logand-c/signed-unsigned=>unsigned
 288              fast-logand-c/unsigned=>unsigned)
 289   (:args (x :target r :scs (signed-reg)
 290             :load-if (or (not (typep y '(unsigned-byte 31)))
 291                          (not (sc-is r signed-reg signed-stack)))))
 292   (:arg-types signed-num (:constant (unsigned-byte 64))))
 293
 294 (define-vop (fast-logand/unsigned-signed=>unsigned
 295              fast-logand/unsigned=>unsigned)
 296   (:args (x :target r :scs (unsigned-reg)
 297             :load-if (not (and (sc-is x unsigned-stack)
 298                                (sc-is y signed-reg)
 299                                (sc-is r unsigned-stack)
 300                                (location= x r))))
 301          (y :scs (signed-reg signed-stack)))
 302   (:arg-types unsigned-num signed-num))
 303 \f
 304
 305 (define-vop (fast-+-c/signed=>signed fast-safe-arith-op)
 306   (:translate +)
 307   (:args (x :target r :scs (signed-reg)
 308             :load-if (or (not (typep y '(signed-byte 32)))
 309                          (not (sc-is r signed-reg signed-stack)))))
 310   (:info y)
 311   (:arg-types signed-num (:constant (signed-byte 64)))
 312   (:results (r :scs (signed-reg)
 313                :load-if (or (not (location= x r))
 314                             (not (typep y '(signed-byte 32))))))
 315   (:result-types signed-num)
 316   (:note "inline (signed-byte 64) arithmetic")
 317   (:generator 4
 318     (cond ((and (sc-is x signed-reg) (sc-is r signed-reg)
 319                 (not (location= x r))
 320                 (typep y '(signed-byte 32)))
 321            (inst lea r (make-ea :qword :base x :disp y)))
 322           (t
 323            (move r x)
 324            (cond ((= y 1)
 325                   (inst inc r))
 326                  ((typep y '(signed-byte 32))
 327                   (inst add r y))
 328                  (t
 329                   (inst add r (register-inline-constant :qword y))))))))
 330
 331 (define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op)
 332   (:translate +)
 333   (:args (x :scs (unsigned-reg) :target r
 334             :load-if (not (and (sc-is x unsigned-stack)
 335                                (sc-is y unsigned-reg)
 336                                (sc-is r unsigned-stack)
 337                                (location= x r))))
 338          (y :scs (unsigned-reg unsigned-stack)))
 339   (:arg-types unsigned-num unsigned-num)
 340   (:results (r :scs (unsigned-reg) :from (:argument 0)
 341                :load-if (not (and (sc-is x unsigned-stack)
 342                                   (sc-is y unsigned-reg)
 343                                   (sc-is r unsigned-stack)
 344                                   (location= x r)))))
 345   (:result-types unsigned-num)
 346   (:note "inline (unsigned-byte 64) arithmetic")
 347   (:generator 5
 348     (cond ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg)
 349                 (sc-is r unsigned-reg) (not (location= x r)))
 350            (inst lea r (make-ea :qword :base x :index y :scale 1)))
 351           (t
 352            (move r x)
 353            (inst add r y)))))
 354
 355 (define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op)
 356   (:translate +)
 357   (:args (x :target r :scs (unsigned-reg)
 358             :load-if (or (not (typep y '(unsigned-byte 31)))
 359                          (not (sc-is x unsigned-reg unsigned-stack)))))
 360   (:info y)
 361   (:arg-types unsigned-num (:constant (unsigned-byte 64)))
 362   (:results (r :scs (unsigned-reg)
 363                :load-if (or (not (location= x r))
 364                             (not (typep y '(unsigned-byte 31))))))
 365   (:result-types unsigned-num)
 366   (:note "inline (unsigned-byte 64) arithmetic")
 367   (:generator 4
 368     (cond ((and (sc-is x unsigned-reg) (sc-is r unsigned-reg)
 369                 (not (location= x r))
 370                 (typep y '(unsigned-byte 31)))
 371            (inst lea r (make-ea :qword :base x :disp y)))
 372           (t
 373            (move r x)
 374            (cond ((= y 1)
 375                   (inst inc r))
 376                  ((typep y '(unsigned-byte 31))
 377                   (inst add r y))
 378                  (t
 379                   (inst add r (register-inline-constant :qword y))))))))
 380 \f
 381 ;;;; multiplication and division
 382
 383 (define-vop (fast-*/fixnum=>fixnum fast-safe-arith-op)
 384   (:translate *)
 385   ;; We need different loading characteristics.
 386   (:args (x :scs (any-reg) :target r)
 387          (y :scs (any-reg control-stack)))
 388   (:arg-types tagged-num tagged-num)
 389   (:results (r :scs (any-reg) :from (:argument 0)))
 390   (:result-types tagged-num)
 391   (:note "inline fixnum arithmetic")
 392   (:generator 4
 393     (move r x)
 394     (inst sar r 3)
 395     (inst imul r y)))
 396
 397 (define-vop (fast-*-c/fixnum=>fixnum fast-safe-arith-op)
 398   (:translate *)
 399   ;; We need different loading characteristics.
 400   (:args (x :scs (any-reg)
 401             :load-if (or (not (typep y '(signed-byte 32)))
 402                          (not (sc-is x any-reg control-stack)))))
 403   (:info y)
 404   (:arg-types tagged-num (:constant fixnum))
 405   (:results (r :scs (any-reg)))
 406   (:result-types tagged-num)
 407   (:note "inline fixnum arithmetic")
 408   (:generator 3
 409     (cond ((typep y '(signed-byte 32))
 410            (inst imul r x y))
 411           (t
 412            (move r x)
 413            (inst imul r (register-inline-constant :qword y))))))
 414
 415 (define-vop (fast-*/signed=>signed fast-safe-arith-op)
 416   (:translate *)
 417   ;; We need different loading characteristics.
 418   (:args (x :scs (signed-reg) :target r)
 419          (y :scs (signed-reg signed-stack)))
 420   (:arg-types signed-num signed-num)
 421   (:results (r :scs (signed-reg) :from (:argument 0)))
 422   (:result-types signed-num)
 423   (:note "inline (signed-byte 64) arithmetic")
 424   (:generator 5
 425     (move r x)
 426     (inst imul r y)))
 427
 428 (define-vop (fast-*-c/signed=>signed fast-safe-arith-op)
 429   (:translate *)
 430   ;; We need different loading characteristics.
 431   (:args (x :scs (signed-reg)
 432             :load-if (or (not (typep y '(signed-byte 32)))
 433                          (not (sc-is x signed-reg signed-stack)))))
 434   (:info y)
 435   (:arg-types signed-num (:constant (signed-byte 64)))
 436   (:results (r :scs (signed-reg)))
 437   (:result-types signed-num)
 438   (:note "inline (signed-byte 64) arithmetic")
 439   (:generator 4
 440     (cond ((typep y '(signed-byte 32))
 441            (inst imul r x y))
 442           (t
 443            (move r x)
 444            (inst imul r (register-inline-constant :qword y))))))
 445
 446 (define-vop (fast-*/unsigned=>unsigned fast-safe-arith-op)
 447   (:translate *)
 448   (:args (x :scs (unsigned-reg) :target eax)
 449          (y :scs (unsigned-reg unsigned-stack)))
 450   (:arg-types unsigned-num unsigned-num)
 451   (:temporary (:sc unsigned-reg :offset eax-offset :target r
 452                    :from (:argument 0) :to :result) eax)
 453   (:temporary (:sc unsigned-reg :offset edx-offset
 454                    :from :eval :to :result) edx)
 455   (:ignore edx)
 456   (:results (r :scs (unsigned-reg)))
 457   (:result-types unsigned-num)
 458   (:note "inline (unsigned-byte 64) arithmetic")
 459   (:vop-var vop)
 460   (:save-p :compute-only)
 461   (:generator 6
 462     (move eax x)
 463     (inst mul eax y)
 464     (move r eax)))
 465
 466 (define-vop (fast-*-c/unsigned=>unsigned fast-safe-arith-op)
 467   (:translate *)
 468   (:args (x :scs (unsigned-reg) :target eax))
 469   (:info y)
 470   (:arg-types unsigned-num (:constant (unsigned-byte 64)))
 471   (:temporary (:sc unsigned-reg :offset eax-offset :target r
 472                    :from (:argument 0) :to :result) eax)
 473   (:temporary (:sc unsigned-reg :offset edx-offset
 474                    :from :eval :to :result) edx)
 475   (:ignore edx)
 476   (:results (r :scs (unsigned-reg)))
 477   (:result-types unsigned-num)
 478   (:note "inline (unsigned-byte 64) arithmetic")
 479   (:vop-var vop)
 480   (:save-p :compute-only)
 481   (:generator 6
 482     (move eax x)
 483     (inst mul eax (register-inline-constant :qword y))
 484     (move r eax)))
 485
 486
 487 (define-vop (fast-truncate/fixnum=>fixnum fast-safe-arith-op)
 488   (:translate truncate)
 489   (:args (x :scs (any-reg) :target eax)
 490          (y :scs (any-reg control-stack)))
 491   (:arg-types tagged-num tagged-num)
 492   (:temporary (:sc signed-reg :offset eax-offset :target quo
 493                    :from (:argument 0) :to (:result 0)) eax)
 494   (:temporary (:sc unsigned-reg :offset edx-offset :target rem
 495                    :from (:argument 0) :to (:result 1)) edx)
 496   (:results (quo :scs (any-reg))
 497             (rem :scs (any-reg)))
 498   (:result-types tagged-num tagged-num)
 499   (:note "inline fixnum arithmetic")
 500   (:vop-var vop)
 501   (:save-p :compute-only)
 502   (:generator 31
 503     (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
 504       (if (sc-is y any-reg)
 505           (inst test y y)  ; smaller instruction
 506           (inst cmp y 0))
 507       (inst jmp :eq zero))
 508     (move eax x)
 509     (inst cqo)
 510     (inst idiv eax y)
 511     (if (location= quo eax)
 512         (inst shl eax 3)
 513         (inst lea quo (make-ea :qword :index eax :scale 8)))
 514     (move rem edx)))
 515
 516 (define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
 517   (:translate truncate)
 518   (:args (x :scs (any-reg) :target eax))
 519   (:info y)
 520   (:arg-types tagged-num (:constant fixnum))
 521   (:temporary (:sc signed-reg :offset eax-offset :target quo
 522                    :from :argument :to (:result 0)) eax)
 523   (:temporary (:sc any-reg :offset edx-offset :target rem
 524                    :from :eval :to (:result 1)) edx)
 525   (:temporary (:sc any-reg :from :eval :to :result) y-arg)
 526   (:results (quo :scs (any-reg))
 527             (rem :scs (any-reg)))
 528   (:result-types tagged-num tagged-num)
 529   (:note "inline fixnum arithmetic")
 530   (:vop-var vop)
 531   (:save-p :compute-only)
 532   (:generator 30
 533     (move eax x)
 534     (inst cqo)
 535     (if (typep y '(signed-byte 29))
 536         (inst mov y-arg (fixnumize y))
 537         (setf y-arg (register-inline-constant :qword (fixnumize y))))
 538     (inst idiv eax y-arg)
 539     (if (location= quo eax)
 540         (inst shl eax 3)
 541         (inst lea quo (make-ea :qword :index eax :scale 8)))
 542     (move rem edx)))
 543
 544 (define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
 545   (:translate truncate)
 546   (:args (x :scs (unsigned-reg) :target eax)
 547          (y :scs (unsigned-reg signed-stack)))
 548   (:arg-types unsigned-num unsigned-num)
 549   (:temporary (:sc unsigned-reg :offset eax-offset :target quo
 550                    :from (:argument 0) :to (:result 0)) eax)
 551   (:temporary (:sc unsigned-reg :offset edx-offset :target rem
 552                    :from (:argument 0) :to (:result 1)) edx)
 553   (:results (quo :scs (unsigned-reg))
 554             (rem :scs (unsigned-reg)))
 555   (:result-types unsigned-num unsigned-num)
 556   (:note "inline (unsigned-byte 64) arithmetic")
 557   (:vop-var vop)
 558   (:save-p :compute-only)
 559   (:generator 33
 560     (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
 561       (if (sc-is y unsigned-reg)
 562           (inst test y y)  ; smaller instruction
 563           (inst cmp y 0))
 564       (inst jmp :eq zero))
 565     (move eax x)
 566     (inst xor edx edx)
 567     (inst div eax y)
 568     (move quo eax)
 569     (move rem edx)))
 570
 571 (define-vop (fast-truncate-c/unsigned=>unsigned fast-safe-arith-op)
 572   (:translate truncate)
 573   (:args (x :scs (unsigned-reg) :target eax))
 574   (:info y)
 575   (:arg-types unsigned-num (:constant (unsigned-byte 64)))
 576   (:temporary (:sc unsigned-reg :offset eax-offset :target quo
 577                    :from :argument :to (:result 0)) eax)
 578   (:temporary (:sc unsigned-reg :offset edx-offset :target rem
 579                    :from :eval :to (:result 1)) edx)
 580   (:temporary (:sc unsigned-reg :from :eval :to :result) y-arg)
 581   (:results (quo :scs (unsigned-reg))
 582             (rem :scs (unsigned-reg)))
 583   (:result-types unsigned-num unsigned-num)
 584   (:note "inline (unsigned-byte 64) arithmetic")
 585   (:vop-var vop)
 586   (:save-p :compute-only)
 587   (:generator 32
 588     (move eax x)
 589     (inst xor edx edx)
 590     (if (typep y '(unsigned-byte 31))
 591         (inst mov y-arg y)
 592         (setf y-arg (register-inline-constant :qword y)))
 593     (inst div eax y-arg)
 594     (move quo eax)
 595     (move rem edx)))
 596
 597 (define-vop (fast-truncate/signed=>signed fast-safe-arith-op)
 598   (:translate truncate)
 599   (:args (x :scs (signed-reg) :target eax)
 600          (y :scs (signed-reg signed-stack)))
 601   (:arg-types signed-num signed-num)
 602   (:temporary (:sc signed-reg :offset eax-offset :target quo
 603                    :from (:argument 0) :to (:result 0)) eax)
 604   (:temporary (:sc signed-reg :offset edx-offset :target rem
 605                    :from (:argument 0) :to (:result 1)) edx)
 606   (:results (quo :scs (signed-reg))
 607             (rem :scs (signed-reg)))
 608   (:result-types signed-num signed-num)
 609   (:note "inline (signed-byte 64) arithmetic")
 610   (:vop-var vop)
 611   (:save-p :compute-only)
 612   (:generator 33
 613     (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
 614       (if (sc-is y signed-reg)
 615           (inst test y y)  ; smaller instruction
 616           (inst cmp y 0))
 617       (inst jmp :eq zero))
 618     (move eax x)
 619     (inst cqo)
 620     (inst idiv eax y)
 621     (move quo eax)
 622     (move rem edx)))
 623
 624 (define-vop (fast-truncate-c/signed=>signed fast-safe-arith-op)
 625   (:translate truncate)
 626   (:args (x :scs (signed-reg) :target eax))
 627   (:info y)
 628   (:arg-types signed-num (:constant (signed-byte 64)))
 629   (:temporary (:sc signed-reg :offset eax-offset :target quo
 630                    :from :argument :to (:result 0)) eax)
 631   (:temporary (:sc signed-reg :offset edx-offset :target rem
 632                    :from :eval :to (:result 1)) edx)
 633   (:temporary (:sc signed-reg :from :eval :to :result) y-arg)
 634   (:results (quo :scs (signed-reg))
 635             (rem :scs (signed-reg)))
 636   (:result-types signed-num signed-num)
 637   (:note "inline (signed-byte 64) arithmetic")
 638   (:vop-var vop)
 639   (:save-p :compute-only)
 640   (:generator 32
 641     (move eax x)
 642     (inst cqo)
 643     (if (typep y '(signed-byte 32))
 644         (inst mov y-arg y)
 645         (setf y-arg (register-inline-constant :qword y)))
 646     (inst idiv eax y-arg)
 647     (move quo eax)
 648     (move rem edx)))
 649
 650
 651 \f
 652 ;;;; Shifting
 653 (define-vop (fast-ash-c/fixnum=>fixnum)
 654   (:translate ash)
 655   (:policy :fast-safe)
 656   (:args (number :scs (any-reg) :target result
 657                  :load-if (not (and (sc-is number any-reg control-stack)
 658                                     (sc-is result any-reg control-stack)
 659                                     (location= number result)))))
 660   (:info amount)
 661   (:arg-types tagged-num (:constant integer))
 662   (:results (result :scs (any-reg)
 663                     :load-if (not (and (sc-is number control-stack)
 664                                        (sc-is result control-stack)
 665                                        (location= number result)))))
 666   (:result-types tagged-num)
 667   (:note "inline ASH")
 668   (:generator 2
 669     (cond ((and (= amount 1) (not (location= number result)))
 670            (inst lea result (make-ea :qword :base number :index number)))
 671           ((and (= amount 2) (not (location= number result)))
 672            (inst lea result (make-ea :qword :index number :scale 4)))
 673           ((and (= amount 3) (not (location= number result)))
 674            (inst lea result (make-ea :qword :index number :scale 8)))
 675           (t
 676            (move result number)
 677            (cond ((< -64 amount 64)
 678                   ;; this code is used both in ASH and ASH-SMOD61, so
 679                   ;; be careful
 680                   (if (plusp amount)
 681                       (inst shl result amount)
 682                       (progn
 683                         (inst sar result (- amount))
 684                         (inst and result (lognot fixnum-tag-mask)))))
 685                  ((plusp amount)
 686                   (if (sc-is result any-reg)
 687                       (inst xor result result)
 688                       (inst mov result 0)))
 689                  (t (inst sar result 63)
 690                     (inst and result (lognot fixnum-tag-mask))))))))
 691
 692 (define-vop (fast-ash-left/fixnum=>fixnum)
 693   (:translate ash)
 694   (:args (number :scs (any-reg) :target result
 695                  :load-if (not (and (sc-is number control-stack)
 696                                     (sc-is result control-stack)
 697                                     (location= number result))))
 698          (amount :scs (unsigned-reg) :target ecx))
 699   (:arg-types tagged-num positive-fixnum)
 700   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
 701   (:results (result :scs (any-reg) :from (:argument 0)
 702                     :load-if (not (and (sc-is number control-stack)
 703                                        (sc-is result control-stack)
 704                                        (location= number result)))))
 705   (:result-types tagged-num)
 706   (:policy :fast-safe)
 707   (:note "inline ASH")
 708   (:generator 3
 709     (move result number)
 710     (move ecx amount)
 711     ;; The result-type ensures us that this shift will not overflow.
 712     (inst shl result :cl)))
 713
 714 (define-vop (fast-ash-c/signed=>signed)
 715   (:translate ash)
 716   (:policy :fast-safe)
 717   (:args (number :scs (signed-reg) :target result
 718                  :load-if (not (and (sc-is number signed-stack)
 719                                     (sc-is result signed-stack)
 720                                     (location= number result)))))
 721   (:info amount)
 722   (:arg-types signed-num (:constant integer))
 723   (:results (result :scs (signed-reg)
 724                     :load-if (not (and (sc-is number signed-stack)
 725                                        (sc-is result signed-stack)
 726                                        (location= number result)))))
 727   (:result-types signed-num)
 728   (:note "inline ASH")
 729   (:generator 3
 730     (cond ((and (= amount 1) (not (location= number result)))
 731            (inst lea result (make-ea :qword :base number :index number)))
 732           ((and (= amount 2) (not (location= number result)))
 733            (inst lea result (make-ea :qword :index number :scale 4)))
 734           ((and (= amount 3) (not (location= number result)))
 735            (inst lea result (make-ea :qword :index number :scale 8)))
 736           (t
 737            (move result number)
 738            (cond ((plusp amount) (inst shl result amount))
 739                  (t (inst sar result (min 63 (- amount)))))))))
 740
 741 (define-vop (fast-ash-c/unsigned=>unsigned)
 742   (:translate ash)
 743   (:policy :fast-safe)
 744   (:args (number :scs (unsigned-reg) :target result
 745                  :load-if (not (and (sc-is number unsigned-stack)
 746                                     (sc-is result unsigned-stack)
 747                                     (location= number result)))))
 748   (:info amount)
 749   (:arg-types unsigned-num (:constant integer))
 750   (:results (result :scs (unsigned-reg)
 751                     :load-if (not (and (sc-is number unsigned-stack)
 752                                        (sc-is result unsigned-stack)
 753                                        (location= number result)))))
 754   (:result-types unsigned-num)
 755   (:note "inline ASH")
 756   (:generator 3
 757     (cond ((and (= amount 1) (not (location= number result)))
 758            (inst lea result (make-ea :qword :base number :index number)))
 759           ((and (= amount 2) (not (location= number result)))
 760            (inst lea result (make-ea :qword :index number :scale 4)))
 761           ((and (= amount 3) (not (location= number result)))
 762            (inst lea result (make-ea :qword :index number :scale 8)))
 763           (t
 764            (move result number)
 765            (cond ((< -64 amount 64) ;; XXXX
 766                   ;; this code is used both in ASH and ASH-MOD32, so
 767                   ;; be careful
 768                   (if (plusp amount)
 769                       (inst shl result amount)
 770                       (inst shr result (- amount))))
 771                  (t (if (sc-is result unsigned-reg)
 772                         (zeroize result)
 773                         (inst mov result 0))))))))
 774
 775 (define-vop (fast-ash-left/signed=>signed)
 776   (:translate ash)
 777   (:args (number :scs (signed-reg) :target result
 778                  :load-if (not (and (sc-is number signed-stack)
 779                                     (sc-is result signed-stack)
 780                                     (location= number result))))
 781          (amount :scs (unsigned-reg) :target ecx))
 782   (:arg-types signed-num positive-fixnum)
 783   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
 784   (:results (result :scs (signed-reg) :from (:argument 0)
 785                     :load-if (not (and (sc-is number signed-stack)
 786                                        (sc-is result signed-stack)
 787                                        (location= number result)))))
 788   (:result-types signed-num)
 789   (:policy :fast-safe)
 790   (:note "inline ASH")
 791   (:generator 4
 792     (move result number)
 793     (move ecx amount)
 794     (inst shl result :cl)))
 795
 796 (define-vop (fast-ash-left/unsigned=>unsigned)
 797   (:translate ash)
 798   (:args (number :scs (unsigned-reg) :target result
 799                  :load-if (not (and (sc-is number unsigned-stack)
 800                                     (sc-is result unsigned-stack)
 801                                     (location= number result))))
 802          (amount :scs (unsigned-reg) :target ecx))
 803   (:arg-types unsigned-num positive-fixnum)
 804   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
 805   (:results (result :scs (unsigned-reg) :from (:argument 0)
 806                     :load-if (not (and (sc-is number unsigned-stack)
 807                                        (sc-is result unsigned-stack)
 808                                        (location= number result)))))
 809   (:result-types unsigned-num)
 810   (:policy :fast-safe)
 811   (:note "inline ASH")
 812   (:generator 4
 813     (move result number)
 814     (move ecx amount)
 815     (inst shl result :cl)))
 816
 817 (define-vop (fast-ash/signed=>signed)
 818   (:translate ash)
 819   (:policy :fast-safe)
 820   (:args (number :scs (signed-reg) :target result)
 821          (amount :scs (signed-reg) :target ecx))
 822   (:arg-types signed-num signed-num)
 823   (:results (result :scs (signed-reg) :from (:argument 0)))
 824   (:result-types signed-num)
 825   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
 826   (:note "inline ASH")
 827   (:generator 5
 828     (move result number)
 829     (move ecx amount)
 830     (inst or ecx ecx)
 831     (inst jmp :ns POSITIVE)
 832     (inst neg ecx)
 833     (inst cmp ecx 63)
 834     (inst jmp :be OKAY)
 835     (inst mov ecx 63)
 836     OKAY
 837     (inst sar result :cl)
 838     (inst jmp DONE)
 839
 840     POSITIVE
 841     ;; The result-type ensures us that this shift will not overflow.
 842     (inst shl result :cl)
 843
 844     DONE))
 845
 846 (define-vop (fast-ash/unsigned=>unsigned)
 847   (:translate ash)
 848   (:policy :fast-safe)
 849   (:args (number :scs (unsigned-reg) :target result)
 850          (amount :scs (signed-reg) :target ecx))
 851   (:arg-types unsigned-num signed-num)
 852   (:results (result :scs (unsigned-reg) :from (:argument 0)))
 853   (:result-types unsigned-num)
 854   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
 855   (:note "inline ASH")
 856   (:generator 5
 857     (move result number)
 858     (move ecx amount)
 859     (inst or ecx ecx)
 860     (inst jmp :ns POSITIVE)
 861     (inst neg ecx)
 862     (inst cmp ecx 63)
 863     (inst jmp :be OKAY)
 864     (zeroize result)
 865     (inst jmp DONE)
 866     OKAY
 867     (inst shr result :cl)
 868     (inst jmp DONE)
 869
 870     POSITIVE
 871     ;; The result-type ensures us that this shift will not overflow.
 872     (inst shl result :cl)
 873
 874     DONE))
 875
 876 (in-package "SB!C")
 877
 878 (defknown %lea (integer integer (member 1 2 4 8 16) (signed-byte 64))
 879   integer
 880   (foldable flushable movable))
 881
 882 (defoptimizer (%lea derive-type) ((base index scale disp))
 883   (when (and (constant-lvar-p scale)
 884              (constant-lvar-p disp))
 885     (let ((scale (lvar-value scale))
 886           (disp (lvar-value disp))
 887           (base-type (lvar-type base))
 888           (index-type (lvar-type index)))
 889       (when (and (numeric-type-p base-type)
 890                  (numeric-type-p index-type))
 891         (let ((base-lo (numeric-type-low base-type))
 892               (base-hi (numeric-type-high base-type))
 893               (index-lo (numeric-type-low index-type))
 894               (index-hi (numeric-type-high index-type)))
 895           (make-numeric-type :class 'integer
 896                              :complexp :real
 897                              :low (when (and base-lo index-lo)
 898                                     (+ base-lo (* index-lo scale) disp))
 899                              :high (when (and base-hi index-hi)
 900                                      (+ base-hi (* index-hi scale) disp))))))))
 901
 902 (defun %lea (base index scale disp)
 903   (+ base (* index scale) disp))
 904
 905 (in-package "SB!VM")
 906
 907 (define-vop (%lea/unsigned=>unsigned)
 908   (:translate %lea)
 909   (:policy :fast-safe)
 910   (:args (base :scs (unsigned-reg))
 911          (index :scs (unsigned-reg)))
 912   (:info scale disp)
 913   (:arg-types unsigned-num unsigned-num
 914               (:constant (member 1 2 4 8))
 915               (:constant (signed-byte 64)))
 916   (:results (r :scs (unsigned-reg)))
 917   (:result-types unsigned-num)
 918   (:generator 5
 919     (inst lea r (make-ea :qword :base base :index index
 920                          :scale scale :disp disp))))
 921
 922 (define-vop (%lea/signed=>signed)
 923   (:translate %lea)
 924   (:policy :fast-safe)
 925   (:args (base :scs (signed-reg))
 926          (index :scs (signed-reg)))
 927   (:info scale disp)
 928   (:arg-types signed-num signed-num
 929               (:constant (member 1 2 4 8))
 930               (:constant (signed-byte 64)))
 931   (:results (r :scs (signed-reg)))
 932   (:result-types signed-num)
 933   (:generator 4
 934     (inst lea r (make-ea :qword :base base :index index
 935                          :scale scale :disp disp))))
 936
 937 (define-vop (%lea/fixnum=>fixnum)
 938   (:translate %lea)
 939   (:policy :fast-safe)
 940   (:args (base :scs (any-reg))
 941          (index :scs (any-reg)))
 942   (:info scale disp)
 943   (:arg-types tagged-num tagged-num
 944               (:constant (member 1 2 4 8))
 945               (:constant (signed-byte 64)))
 946   (:results (r :scs (any-reg)))
 947   (:result-types tagged-num)
 948   (:generator 3
 949     (inst lea r (make-ea :qword :base base :index index
 950                          :scale scale :disp disp))))
 951
 952 ;;; FIXME: before making knowledge of this too public, it needs to be
 953 ;;; fixed so that it's actually _faster_ than the non-CMOV version; at
 954 ;;; least on my Celeron-XXX laptop, this version is marginally slower
 955 ;;; than the above version with branches.  -- CSR, 2003-09-04
 956 (define-vop (fast-cmov-ash/unsigned=>unsigned)
 957   (:translate ash)
 958   (:policy :fast-safe)
 959   (:args (number :scs (unsigned-reg) :target result)
 960          (amount :scs (signed-reg) :target ecx))
 961   (:arg-types unsigned-num signed-num)
 962   (:results (result :scs (unsigned-reg) :from (:argument 0)))
 963   (:result-types unsigned-num)
 964   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
 965   (:temporary (:sc any-reg :from (:eval 0) :to (:eval 1)) zero)
 966   (:note "inline ASH")
 967   (:guard (member :cmov *backend-subfeatures*))
 968   (:generator 4
 969     (move result number)
 970     (move ecx amount)
 971     (inst or ecx ecx)
 972     (inst jmp :ns POSITIVE)
 973     (inst neg ecx)
 974     (zeroize zero)
 975     (inst shr result :cl)
 976     (inst cmp ecx 63)
 977     (inst cmov :nbe result zero)
 978     (inst jmp DONE)
 979
 980     POSITIVE
 981     ;; The result-type ensures us that this shift will not overflow.
 982     (inst shl result :cl)
 983
 984     DONE))
 985 \f
 986 (define-vop (signed-byte-64-len)
 987   (:translate integer-length)
 988   (:note "inline (signed-byte 64) integer-length")
 989   (:policy :fast-safe)
 990   (:args (arg :scs (signed-reg) :target res))
 991   (:arg-types signed-num)
 992   (:results (res :scs (unsigned-reg)))
 993   (:result-types unsigned-num)
 994   (:generator 28
 995     (move res arg)
 996     (if (sc-is res unsigned-reg)
 997         (inst test res res)
 998         (inst cmp res 0))
 999     (inst jmp :ge POS)
1000     (inst not res)
1001     POS
1002     (inst bsr res res)
1003     (inst jmp :z ZERO)
1004     (inst inc res)
1005     (inst jmp DONE)
1006     ZERO
1007     (zeroize res)
1008     DONE))
1009
1010 (define-vop (unsigned-byte-64-len)
1011   (:translate integer-length)
1012   (:note "inline (unsigned-byte 64) integer-length")
1013   (:policy :fast-safe)
1014   (:args (arg :scs (unsigned-reg)))
1015   (:arg-types unsigned-num)
1016   (:results (res :scs (unsigned-reg)))
1017   (:result-types unsigned-num)
1018   (:generator 26
1019     (inst bsr res arg)
1020     (inst jmp :z ZERO)
1021     (inst inc res)
1022     (inst jmp DONE)
1023     ZERO
1024     (zeroize res)
1025     DONE))
1026
1027 (define-vop (unsigned-byte-64-count)
1028   (:translate logcount)
1029   (:note "inline (unsigned-byte 64) logcount")
1030   (:policy :fast-safe)
1031   (:args (arg :scs (unsigned-reg) :target result))
1032   (:arg-types unsigned-num)
1033   (:results (result :scs (unsigned-reg)))
1034   (:result-types positive-fixnum)
1035   (:temporary (:sc unsigned-reg) temp)
1036   (:temporary (:sc unsigned-reg) mask)
1037   (:generator 14
1038     ;; See the comments below for how the algorithm works. The tricks
1039     ;; used can be found for example in AMD's software optimization
1040     ;; guide or at "http://www.hackersdelight.org/HDcode/pop.cc" in the
1041     ;; function "pop1", for 32-bit words. The extension to 64 bits is
1042     ;; straightforward.
1043     ;; Calculate 2-bit sums. Note that the value of a two-digit binary
1044     ;; number is the sum of the right digit and twice the left digit.
1045     ;; Thus we can calculate the sum of the two digits by shifting the
1046     ;; left digit to the right position and doing a two-bit subtraction.
1047     ;; This subtraction will never create a borrow and thus can be made
1048     ;; on all 32 2-digit numbers at once.
1049     (move result arg)
1050     (move temp arg)
1051     (inst shr result 1)
1052     (inst mov mask #x5555555555555555)
1053     (inst and result mask)
1054     (inst sub temp result)
1055     ;; Calculate 4-bit sums by straightforward shift, mask and add.
1056     ;; Note that we shift the source operand of the MOV and not its
1057     ;; destination so that the SHR and the MOV can execute in the same
1058     ;; clock cycle.
1059     (inst mov result temp)
1060     (inst shr temp 2)
1061     (inst mov mask #x3333333333333333)
1062     (inst and result mask)
1063     (inst and temp mask)
1064     (inst add result temp)
1065     ;; Calculate 8-bit sums. Since each sum is at most 8, which fits
1066     ;; into 4 bits, we can apply the mask after the addition, saving one
1067     ;; instruction.
1068     (inst mov temp result)
1069     (inst shr result 4)
1070     (inst add result temp)
1071     (inst mov mask #x0f0f0f0f0f0f0f0f)
1072     (inst and result mask)
1073     ;; Add all 8 bytes at once by multiplying with #256r11111111.
1074     ;; We need to calculate only the lower 8 bytes of the product.
1075     ;; Of these the most significant byte contains the final result.
1076     ;; Note that there can be no overflow from one byte to the next
1077     ;; as the sum is at most 64 which needs only 7 bits.
1078     (inst mov mask #x0101010101010101)
1079     (inst imul result mask)
1080     (inst shr result 56)))
1081 \f
1082 ;;;; binary conditional VOPs
1083
1084 (define-vop (fast-conditional)
1085   (:conditional :e)
1086   (:info)
1087   (:effects)
1088   (:affected)
1089   (:policy :fast-safe))
1090
1091 ;;; constant variants are declared for 32 bits not 64 bits, because
1092 ;;; loading a 64 bit constant is silly
1093
1094 (define-vop (fast-conditional/fixnum fast-conditional)
1095   (:args (x :scs (any-reg)
1096             :load-if (not (and (sc-is x control-stack)
1097                                (sc-is y any-reg))))
1098          (y :scs (any-reg control-stack)))
1099   (:arg-types tagged-num tagged-num)
1100   (:note "inline fixnum comparison"))
1101
1102 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
1103   (:args (x :scs (any-reg)
1104             :load-if (or (not (typep y '(signed-byte 29)))
1105                          (not (sc-is x any-reg control-stack)))))
1106   (:arg-types tagged-num (:constant fixnum))
1107   (:info y))
1108
1109 (define-vop (fast-conditional/signed fast-conditional)
1110   (:args (x :scs (signed-reg)
1111             :load-if (not (and (sc-is x signed-stack)
1112                                (sc-is y signed-reg))))
1113          (y :scs (signed-reg signed-stack)))
1114   (:arg-types signed-num signed-num)
1115   (:note "inline (signed-byte 64) comparison"))
1116
1117 (define-vop (fast-conditional-c/signed fast-conditional/signed)
1118   (:args (x :scs (signed-reg)
1119             :load-if (or (not (typep y '(signed-byte 32)))
1120                          (not (sc-is x signed-reg signed-stack)))))
1121   (:arg-types signed-num (:constant (signed-byte 64)))
1122   (:info y))
1123
1124 (define-vop (fast-conditional/unsigned fast-conditional)
1125   (:args (x :scs (unsigned-reg)
1126             :load-if (not (and (sc-is x unsigned-stack)
1127                                (sc-is y unsigned-reg))))
1128          (y :scs (unsigned-reg unsigned-stack)))
1129   (:arg-types unsigned-num unsigned-num)
1130   (:note "inline (unsigned-byte 64) comparison"))
1131
1132 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
1133   (:args (x :scs (unsigned-reg)
1134             :load-if (or (not (typep y '(unsigned-byte 31)))
1135                          (not (sc-is x unsigned-reg unsigned-stack)))))
1136   (:arg-types unsigned-num (:constant (unsigned-byte 64)))
1137   (:info y))
1138
1139 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
1140              `(progn
1141                 ,@(mapcar
1142                    (lambda (suffix cost signed)
1143                      `(define-vop (;; FIXME: These could be done more
1144                                    ;; cleanly with SYMBOLICATE.
1145                                    ,(intern (format nil "~:@(FAST-IF-~A~A~)"
1146                                                     tran suffix))
1147                                    ,(intern
1148                                      (format nil "~:@(FAST-CONDITIONAL~A~)"
1149                                              suffix)))
1150                         (:translate ,tran)
1151                         (:conditional ,(if signed cond unsigned))
1152                         (:generator ,cost
1153                                     (inst cmp x
1154                                           ,(case suffix
1155                                              (-c/fixnum
1156                                                 `(if (typep y '(signed-byte 29))
1157                                                      (fixnumize y)
1158                                                      (register-inline-constant
1159                                                       :qword (fixnumize y))))
1160                                              (-c/signed
1161                                                 `(if (typep y '(signed-byte 32))
1162                                                      y
1163                                                      (register-inline-constant
1164                                                       :qword y)))
1165                                              (-c/unsigned
1166                                                 `(if (typep y '(unsigned-byte 31))
1167                                                      y
1168                                                      (register-inline-constant
1169                                                       :qword y)))
1170                                              (t 'y))))))
1171                    '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
1172 ;                  '(/fixnum  /signed  /unsigned)
1173                    '(4 3 6 5 6 5)
1174                    '(t t t t nil nil)))))
1175
1176   (define-conditional-vop < :l :b :ge :ae)
1177   (define-conditional-vop > :g :a :le :be))
1178
1179 (define-vop (fast-if-eql/signed fast-conditional/signed)
1180   (:translate eql)
1181   (:generator 6
1182     (inst cmp x y)))
1183
1184 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
1185   (:translate eql)
1186   (:generator 5
1187     (cond ((and (sc-is x signed-reg) (zerop y))
1188            (inst test x x))  ; smaller instruction
1189           ((typep y '(signed-byte 32))
1190            (inst cmp x y))
1191           (t
1192            (inst cmp x (register-inline-constant :qword y))))))
1193
1194 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
1195   (:translate eql)
1196   (:generator 6
1197     (inst cmp x y)))
1198
1199 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
1200   (:translate eql)
1201   (:generator 5
1202     (cond ((and (sc-is x unsigned-reg) (zerop y))
1203            (inst test x x))  ; smaller instruction
1204           ((typep y '(unsigned-byte 31))
1205            (inst cmp x y))
1206           (t
1207            (inst cmp x (register-inline-constant :qword y))))))
1208
1209 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
1210 ;;; known fixnum.
1211
1212 ;;; These versions specify a fixnum restriction on their first arg. We have
1213 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
1214 ;;; the first arg and a higher cost. The reason for doing this is to prevent
1215 ;;; fixnum specific operations from being used on word integers, spuriously
1216 ;;; consing the argument.
1217
1218 (define-vop (fast-eql/fixnum fast-conditional)
1219   (:args (x :scs (any-reg)
1220             :load-if (not (and (sc-is x control-stack)
1221                                (sc-is y any-reg))))
1222          (y :scs (any-reg control-stack)))
1223   (:arg-types tagged-num tagged-num)
1224   (:note "inline fixnum comparison")
1225   (:translate eql)
1226   (:generator 4
1227     (inst cmp x y)))
1228
1229 (define-vop (generic-eql/fixnum fast-eql/fixnum)
1230   (:args (x :scs (any-reg descriptor-reg)
1231             :load-if (not (and (sc-is x control-stack)
1232                                (sc-is y any-reg))))
1233          (y :scs (any-reg control-stack)))
1234   (:arg-types * tagged-num)
1235   (:variant-cost 7))
1236
1237 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
1238   (:args (x :scs (any-reg)
1239             :load-if (or (not (typep y '(signed-byte 29)))
1240                          (not (sc-is x any-reg descriptor-reg control-stack)))))
1241   (:arg-types tagged-num (:constant fixnum))
1242   (:info y)
1243   (:translate eql)
1244   (:generator 2
1245     (cond ((and (sc-is x any-reg descriptor-reg) (zerop y))
1246            (inst test x x))  ; smaller instruction
1247           ((typep y '(signed-byte 29))
1248            (inst cmp x (fixnumize y)))
1249           (t
1250            (inst cmp x (register-inline-constant :qword (fixnumize y)))))))
1251
1252 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
1253   (:args (x :scs (any-reg descriptor-reg)))
1254   (:arg-types * (:constant fixnum))
1255   (:variant-cost 6))
1256 \f
1257 ;;;; 32-bit logical operations
1258
1259 ;;; Only the lower 6 bits of the shift amount are significant.
1260 (define-vop (shift-towards-someplace)
1261   (:policy :fast-safe)
1262   (:args (num :scs (unsigned-reg) :target r)
1263          (amount :scs (signed-reg) :target ecx))
1264   (:arg-types unsigned-num tagged-num)
1265   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
1266   (:results (r :scs (unsigned-reg) :from (:argument 0)))
1267   (:result-types unsigned-num))
1268
1269 (define-vop (shift-towards-start shift-towards-someplace)
1270   (:translate shift-towards-start)
1271   (:note "SHIFT-TOWARDS-START")
1272   (:generator 1
1273     (move r num)
1274     (move ecx amount)
1275     (inst shr r :cl)))
1276
1277 (define-vop (shift-towards-end shift-towards-someplace)
1278   (:translate shift-towards-end)
1279   (:note "SHIFT-TOWARDS-END")
1280   (:generator 1
1281     (move r num)
1282     (move ecx amount)
1283     (inst shl r :cl)))
1284 \f
1285 ;;;; Modular functions
1286
1287 (defmacro define-mod-binop ((name prototype) function)
1288   `(define-vop (,name ,prototype)
1289        (:args (x :target r :scs (unsigned-reg signed-reg)
1290                  :load-if (not (and (or (sc-is x unsigned-stack)
1291                                         (sc-is x signed-stack))
1292                                     (or (sc-is y unsigned-reg)
1293                                         (sc-is y signed-reg))
1294                                     (or (sc-is r unsigned-stack)
1295                                         (sc-is r signed-stack))
1296                                     (location= x r))))
1297               (y :scs (unsigned-reg signed-reg unsigned-stack signed-stack)))
1298      (:arg-types untagged-num untagged-num)
1299      (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1300                   :load-if (not (and (or (sc-is x unsigned-stack)
1301                                          (sc-is x signed-stack))
1302                                      (or (sc-is y unsigned-reg)
1303                                          (sc-is y unsigned-reg))
1304                                      (or (sc-is r unsigned-stack)
1305                                          (sc-is r unsigned-stack))
1306                                      (location= x r)))))
1307      (:result-types unsigned-num)
1308      (:translate ,function)))
1309 (defmacro define-mod-binop-c ((name prototype) function)
1310   `(define-vop (,name ,prototype)
1311        (:args (x :target r :scs (unsigned-reg signed-reg)
1312                  :load-if (not (and (or (sc-is x unsigned-stack)
1313                                         (sc-is x signed-stack))
1314                                     (or (sc-is r unsigned-stack)
1315                                         (sc-is r signed-stack))
1316                                     (location= x r)
1317                                     (typep y '(signed-byte 32))))))
1318      (:info y)
1319      (:arg-types untagged-num (:constant (or (unsigned-byte 64) (signed-byte 64))))
1320      (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1321                   :load-if (not (and (or (sc-is x unsigned-stack)
1322                                          (sc-is x signed-stack))
1323                                      (or (sc-is r unsigned-stack)
1324                                          (sc-is r unsigned-stack))
1325                                      (location= x r)))))
1326      (:result-types unsigned-num)
1327      (:translate ,function)))
1328
1329 (macrolet ((def (name -c-p)
1330              (let ((fun64 (intern (format nil "~S-MOD64" name)))
1331                    (vopu (intern (format nil "FAST-~S/UNSIGNED=>UNSIGNED" name)))
1332                    (vopcu (intern (format nil "FAST-~S-C/UNSIGNED=>UNSIGNED" name)))
1333                    (vopf (intern (format nil "FAST-~S/FIXNUM=>FIXNUM" name)))
1334                    (vopcf (intern (format nil "FAST-~S-C/FIXNUM=>FIXNUM" name)))
1335                    (vop64u (intern (format nil "FAST-~S-MOD64/WORD=>UNSIGNED" name)))
1336                    (vop64f (intern (format nil "FAST-~S-MOD64/FIXNUM=>FIXNUM" name)))
1337                    (vop64cu (intern (format nil "FAST-~S-MOD64-C/WORD=>UNSIGNED" name)))
1338                    (vop64cf (intern (format nil "FAST-~S-MOD64-C/FIXNUM=>FIXNUM" name)))
1339                    (sfun61 (intern (format nil "~S-SMOD61" name)))
1340                    (svop61f (intern (format nil "FAST-~S-SMOD61/FIXNUM=>FIXNUM" name)))
1341                    (svop61cf (intern (format nil "FAST-~S-SMOD61-C/FIXNUM=>FIXNUM" name))))
1342                `(progn
1343                   (define-modular-fun ,fun64 (x y) ,name :untagged nil 64)
1344                   (define-modular-fun ,sfun61 (x y) ,name :tagged t 61)
1345                   (define-mod-binop (,vop64u ,vopu) ,fun64)
1346                   (define-vop (,vop64f ,vopf) (:translate ,fun64))
1347                   (define-vop (,svop61f ,vopf) (:translate ,sfun61))
1348                   ,@(when -c-p
1349                       `((define-mod-binop-c (,vop64cu ,vopcu) ,fun64)
1350                         (define-vop (,svop61cf ,vopcf) (:translate ,sfun61))))))))
1351   (def + t)
1352   (def - t)
1353   (def * t))
1354
1355 (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
1356              fast-ash-c/unsigned=>unsigned)
1357   (:translate ash-left-mod64))
1358 (define-vop (fast-ash-left-mod64/unsigned=>unsigned
1359              fast-ash-left/unsigned=>unsigned))
1360 (deftransform ash-left-mod64 ((integer count)
1361                               ((unsigned-byte 64) (unsigned-byte 6)))
1362   (when (sb!c::constant-lvar-p count)
1363     (sb!c::give-up-ir1-transform))
1364   '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
1365
1366 (define-vop (fast-ash-left-smod61-c/fixnum=>fixnum
1367              fast-ash-c/fixnum=>fixnum)
1368   (:translate ash-left-smod61))
1369 (define-vop (fast-ash-left-smod61/fixnum=>fixnum
1370              fast-ash-left/fixnum=>fixnum))
1371 (deftransform ash-left-smod61 ((integer count)
1372                                ((signed-byte 61) (unsigned-byte 6)))
1373   (when (sb!c::constant-lvar-p count)
1374     (sb!c::give-up-ir1-transform))
1375   '(%primitive fast-ash-left-smod61/fixnum=>fixnum integer count))
1376
1377 (in-package "SB!C")
1378
1379 (defknown sb!vm::%lea-mod64 (integer integer (member 1 2 4 8) (signed-byte 64))
1380   (unsigned-byte 64)
1381   (foldable flushable movable))
1382 (defknown sb!vm::%lea-smod61 (integer integer (member 1 2 4 8) (signed-byte 64))
1383   (signed-byte 61)
1384   (foldable flushable movable))
1385
1386 (define-modular-fun-optimizer %lea ((base index scale disp) :untagged nil :width width)
1387   (when (and (<= width 64)
1388              (constant-lvar-p scale)
1389              (constant-lvar-p disp))
1390     (cut-to-width base :untagged width nil)
1391     (cut-to-width index :untagged width nil)
1392     'sb!vm::%lea-mod64))
1393 (define-modular-fun-optimizer %lea ((base index scale disp) :tagged t :width width)
1394   (when (and (<= width 61)
1395              (constant-lvar-p scale)
1396              (constant-lvar-p disp))
1397     (cut-to-width base :tagged width t)
1398     (cut-to-width index :tagged width t)
1399     'sb!vm::%lea-smod61))
1400
1401 #+sb-xc-host
1402 (progn
1403   (defun sb!vm::%lea-mod64 (base index scale disp)
1404     (ldb (byte 64 0) (%lea base index scale disp)))
1405   (defun sb!vm::%lea-smod61 (base index scale disp)
1406     (mask-signed-field 61 (%lea base index scale disp))))
1407 #-sb-xc-host
1408 (progn
1409   (defun sb!vm::%lea-mod64 (base index scale disp)
1410     (let ((base (logand base #xffffffffffffffff))
1411           (index (logand index #xffffffffffffffff)))
1412       ;; can't use modular version of %LEA, as we only have VOPs for
1413       ;; constant SCALE and DISP.
1414       (ldb (byte 64 0) (+ base (* index scale) disp))))
1415   (defun sb!vm::%lea-smod61 (base index scale disp)
1416     (let ((base (mask-signed-field 61 base))
1417           (index (mask-signed-field 61 index)))
1418       ;; can't use modular version of %LEA, as we only have VOPs for
1419       ;; constant SCALE and DISP.
1420       (mask-signed-field 61 (+ base (* index scale) disp)))))
1421
1422 (in-package "SB!VM")
1423
1424 (define-vop (%lea-mod64/unsigned=>unsigned
1425              %lea/unsigned=>unsigned)
1426   (:translate %lea-mod64))
1427 (define-vop (%lea-smod61/fixnum=>fixnum
1428              %lea/fixnum=>fixnum)
1429   (:translate %lea-smod61))
1430
1431 ;;; logical operations
1432 (define-modular-fun lognot-mod64 (x) lognot :untagged nil 64)
1433 (define-vop (lognot-mod64/unsigned=>unsigned)
1434   (:translate lognot-mod64)
1435   (:args (x :scs (unsigned-reg unsigned-stack) :target r
1436             :load-if (not (and (sc-is x unsigned-stack)
1437                                (sc-is r unsigned-stack)
1438                                (location= x r)))))
1439   (:arg-types unsigned-num)
1440   (:results (r :scs (unsigned-reg)
1441                :load-if (not (and (sc-is x unsigned-stack)
1442                                   (sc-is r unsigned-stack)
1443                                   (location= x r)))))
1444   (:result-types unsigned-num)
1445   (:policy :fast-safe)
1446   (:generator 1
1447     (move r x)
1448     (inst not r)))
1449
1450 (define-source-transform logeqv (&rest args)
1451   (if (oddp (length args))
1452       `(logxor ,@args)
1453       `(lognot (logxor ,@args))))
1454 (define-source-transform logandc1 (x y)
1455   `(logand (lognot ,x) ,y))
1456 (define-source-transform logandc2 (x y)
1457   `(logand ,x (lognot ,y)))
1458 (define-source-transform logorc1 (x y)
1459   `(logior (lognot ,x) ,y))
1460 (define-source-transform logorc2 (x y)
1461   `(logior ,x (lognot ,y)))
1462 (define-source-transform lognor (x y)
1463   `(lognot (logior ,x ,y)))
1464 (define-source-transform lognand (x y)
1465   `(lognot (logand ,x ,y)))
1466 \f
1467 ;;;; bignum stuff
1468
1469 (define-vop (bignum-length get-header-data)
1470   (:translate sb!bignum:%bignum-length)
1471   (:policy :fast-safe))
1472
1473 (define-vop (bignum-set-length set-header-data)
1474   (:translate sb!bignum:%bignum-set-length)
1475   (:policy :fast-safe))
1476
1477 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
1478   (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
1479 (define-full-reffer+offset bignum--ref-with-offset * bignum-digits-offset
1480   other-pointer-lowtag (unsigned-reg) unsigned-num
1481   sb!bignum:%bignum-ref-with-offset)
1482 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
1483   (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
1484
1485 (define-vop (digit-0-or-plus)
1486   (:translate sb!bignum:%digit-0-or-plusp)
1487   (:policy :fast-safe)
1488   (:args (digit :scs (unsigned-reg)))
1489   (:arg-types unsigned-num)
1490   (:conditional :ns)
1491   (:generator 3
1492     (inst or digit digit)))
1493
1494
1495 ;;; For add and sub with carry the sc of carry argument is any-reg so
1496 ;;; that it may be passed as a fixnum or word and thus may be 0, 1, or
1497 ;;; 8. This is easy to deal with and may save a fixnum-word
1498 ;;; conversion.
1499 (define-vop (add-w/carry)
1500   (:translate sb!bignum:%add-with-carry)
1501   (:policy :fast-safe)
1502   (:args (a :scs (unsigned-reg) :target result)
1503          (b :scs (unsigned-reg unsigned-stack) :to :eval)
1504          (c :scs (any-reg) :target temp))
1505   (:arg-types unsigned-num unsigned-num positive-fixnum)
1506   (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
1507   (:results (result :scs (unsigned-reg) :from (:argument 0))
1508             (carry :scs (unsigned-reg)))
1509   (:result-types unsigned-num positive-fixnum)
1510   (:generator 4
1511     (move result a)
1512     (move temp c)
1513     (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
1514     (inst adc result b)
1515     (inst mov carry 0)
1516     (inst adc carry carry)))
1517
1518 ;;; Note: the borrow is 1 for no borrow and 0 for a borrow, the opposite
1519 ;;; of the x86-64 convention.
1520 (define-vop (sub-w/borrow)
1521   (:translate sb!bignum:%subtract-with-borrow)
1522   (:policy :fast-safe)
1523   (:args (a :scs (unsigned-reg) :to :eval :target result)
1524          (b :scs (unsigned-reg unsigned-stack) :to :result)
1525          (c :scs (any-reg control-stack)))
1526   (:arg-types unsigned-num unsigned-num positive-fixnum)
1527   (:results (result :scs (unsigned-reg) :from :eval)
1528             (borrow :scs (unsigned-reg)))
1529   (:result-types unsigned-num positive-fixnum)
1530   (:generator 5
1531     (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
1532     (move result a)
1533     (inst sbb result b)
1534     (inst mov borrow 1)
1535     (inst sbb borrow 0)))
1536
1537
1538 (define-vop (bignum-mult-and-add-3-arg)
1539   (:translate sb!bignum:%multiply-and-add)
1540   (:policy :fast-safe)
1541   (:args (x :scs (unsigned-reg) :target eax)
1542          (y :scs (unsigned-reg unsigned-stack))
1543          (carry-in :scs (unsigned-reg unsigned-stack)))
1544   (:arg-types unsigned-num unsigned-num unsigned-num)
1545   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1546                    :to (:result 1) :target lo) eax)
1547   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1548                    :to (:result 0) :target hi) edx)
1549   (:results (hi :scs (unsigned-reg))
1550             (lo :scs (unsigned-reg)))
1551   (:result-types unsigned-num unsigned-num)
1552   (:generator 20
1553     (move eax x)
1554     (inst mul eax y)
1555     (inst add eax carry-in)
1556     (inst adc edx 0)
1557     (move hi edx)
1558     (move lo eax)))
1559
1560 (define-vop (bignum-mult-and-add-4-arg)
1561   (:translate sb!bignum:%multiply-and-add)
1562   (:policy :fast-safe)
1563   (:args (x :scs (unsigned-reg) :target eax)
1564          (y :scs (unsigned-reg unsigned-stack))
1565          (prev :scs (unsigned-reg unsigned-stack))
1566          (carry-in :scs (unsigned-reg unsigned-stack)))
1567   (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1568   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1569                    :to (:result 1) :target lo) eax)
1570   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1571                    :to (:result 0) :target hi) edx)
1572   (:results (hi :scs (unsigned-reg))
1573             (lo :scs (unsigned-reg)))
1574   (:result-types unsigned-num unsigned-num)
1575   (:generator 20
1576     (move eax x)
1577     (inst mul eax y)
1578     (inst add eax prev)
1579     (inst adc edx 0)
1580     (inst add eax carry-in)
1581     (inst adc edx 0)
1582     (move hi edx)
1583     (move lo eax)))
1584
1585
1586 (define-vop (bignum-mult)
1587   (:translate sb!bignum:%multiply)
1588   (:policy :fast-safe)
1589   (:args (x :scs (unsigned-reg) :target eax)
1590          (y :scs (unsigned-reg unsigned-stack)))
1591   (:arg-types unsigned-num unsigned-num)
1592   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1593                    :to (:result 1) :target lo) eax)
1594   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1595                    :to (:result 0) :target hi) edx)
1596   (:results (hi :scs (unsigned-reg))
1597             (lo :scs (unsigned-reg)))
1598   (:result-types unsigned-num unsigned-num)
1599   (:generator 20
1600     (move eax x)
1601     (inst mul eax y)
1602     (move hi edx)
1603     (move lo eax)))
1604
1605 (define-vop (bignum-lognot lognot-mod64/unsigned=>unsigned)
1606   (:translate sb!bignum:%lognot))
1607
1608 (define-vop (fixnum-to-digit)
1609   (:translate sb!bignum:%fixnum-to-digit)
1610   (:policy :fast-safe)
1611   (:args (fixnum :scs (any-reg control-stack) :target digit))
1612   (:arg-types tagged-num)
1613   (:results (digit :scs (unsigned-reg)
1614                    :load-if (not (and (sc-is fixnum control-stack)
1615                                       (sc-is digit unsigned-stack)
1616                                       (location= fixnum digit)))))
1617   (:result-types unsigned-num)
1618   (:generator 1
1619     (move digit fixnum)
1620     (inst sar digit 3)))
1621
1622 (define-vop (bignum-floor)
1623   (:translate sb!bignum:%floor)
1624   (:policy :fast-safe)
1625   (:args (div-high :scs (unsigned-reg) :target edx)
1626          (div-low :scs (unsigned-reg) :target eax)
1627          (divisor :scs (unsigned-reg unsigned-stack)))
1628   (:arg-types unsigned-num unsigned-num unsigned-num)
1629   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
1630                    :to (:result 0) :target quo) eax)
1631   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
1632                    :to (:result 1) :target rem) edx)
1633   (:results (quo :scs (unsigned-reg))
1634             (rem :scs (unsigned-reg)))
1635   (:result-types unsigned-num unsigned-num)
1636   (:generator 300
1637     (move edx div-high)
1638     (move eax div-low)
1639     (inst div eax divisor)
1640     (move quo eax)
1641     (move rem edx)))
1642
1643 (define-vop (signify-digit)
1644   (:translate sb!bignum:%fixnum-digit-with-correct-sign)
1645   (:policy :fast-safe)
1646   (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
1647   (:arg-types unsigned-num)
1648   (:results (res :scs (any-reg signed-reg)
1649                  :load-if (not (and (sc-is digit unsigned-stack)
1650                                     (sc-is res control-stack signed-stack)
1651                                     (location= digit res)))))
1652   (:result-types signed-num)
1653   (:generator 1
1654     (move res digit)
1655     (when (sc-is res any-reg control-stack)
1656       (inst shl res 3))))
1657
1658 (define-vop (digit-ashr)
1659   (:translate sb!bignum:%ashr)
1660   (:policy :fast-safe)
1661   (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
1662          (count :scs (unsigned-reg) :target ecx))
1663   (:arg-types unsigned-num positive-fixnum)
1664   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
1665   (:results (result :scs (unsigned-reg) :from (:argument 0)
1666                     :load-if (not (and (sc-is result unsigned-stack)
1667                                        (location= digit result)))))
1668   (:result-types unsigned-num)
1669   (:generator 2
1670     (move result digit)
1671     (move ecx count)
1672     (inst sar result :cl)))
1673
1674 (define-vop (digit-ashr/c)
1675   (:translate sb!bignum:%ashr)
1676   (:policy :fast-safe)
1677   (:args (digit :scs (unsigned-reg unsigned-stack) :target result))
1678   (:arg-types unsigned-num (:constant (integer 0 63)))
1679   (:info count)
1680   (:results (result :scs (unsigned-reg) :from (:argument 0)
1681                     :load-if (not (and (sc-is result unsigned-stack)
1682                                        (location= digit result)))))
1683   (:result-types unsigned-num)
1684   (:generator 1
1685     (move result digit)
1686     (inst sar result count)))
1687
1688 (define-vop (digit-lshr digit-ashr)
1689   (:translate sb!bignum:%digit-logical-shift-right)
1690   (:generator 1
1691     (move result digit)
1692     (move ecx count)
1693     (inst shr result :cl)))
1694
1695 (define-vop (digit-ashl digit-ashr)
1696   (:translate sb!bignum:%ashl)
1697   (:generator 1
1698     (move result digit)
1699     (move ecx count)
1700     (inst shl result :cl)))
1701 \f
1702 ;;;; static functions
1703
1704 (define-static-fun two-arg-/ (x y) :translate /)
1705
1706 (define-static-fun two-arg-gcd (x y) :translate gcd)
1707 (define-static-fun two-arg-lcm (x y) :translate lcm)
1708
1709 (define-static-fun two-arg-and (x y) :translate logand)
1710 (define-static-fun two-arg-ior (x y) :translate logior)
1711 (define-static-fun two-arg-xor (x y) :translate logxor)
1712
1713
1714 (in-package "SB!C")
1715
1716 (defun *-transformer (y)
1717   (cond
1718     ((= y (ash 1 (integer-length y)))
1719      ;; there's a generic transform for y = 2^k
1720      (give-up-ir1-transform))
1721     ((member y '(3 5 9))
1722      ;; we can do these multiplications directly using LEA
1723      `(%lea x x ,(1- y) 0))
1724     (t
1725      ;; A normal 64-bit multiplication takes 4 cycles on Athlon 64/Opteron.
1726      ;; Optimizing multiplications (other than the above cases) to
1727      ;; shifts/adds/leas gives a maximum improvement of 1 cycle, but requires
1728      ;; quite a lot of hairy code.
1729      (give-up-ir1-transform))))
1730
1731 (deftransform * ((x y)
1732                  ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1733                  (unsigned-byte 64))
1734   "recode as leas, shifts and adds"
1735   (let ((y (lvar-value y)))
1736     (*-transformer y)))
1737 (deftransform sb!vm::*-mod64
1738     ((x y) ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1739      (unsigned-byte 64))
1740   "recode as leas, shifts and adds"
1741   (let ((y (lvar-value y)))
1742     (*-transformer y)))
1743
1744 (deftransform * ((x y)
1745                  ((signed-byte 61) (constant-arg (unsigned-byte 64)))
1746                  (signed-byte 61))
1747   "recode as leas, shifts and adds"
1748   (let ((y (lvar-value y)))
1749     (*-transformer y)))
1750 (deftransform sb!vm::*-smod61
1751     ((x y) ((signed-byte 61) (constant-arg (unsigned-byte 64)))
1752      (signed-byte 61))
1753   "recode as leas, shifts and adds"
1754   (let ((y (lvar-value y)))
1755     (*-transformer y)))