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 n-fixnum-tag-bits)
 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 n-fixnum-tag-bits)
 513         (inst lea quo (make-ea :qword :index eax
 514                                :scale (ash 1 n-fixnum-tag-bits))))
 515     (move rem edx)))
 516
 517 (define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
 518   (:translate truncate)
 519   (:args (x :scs (any-reg) :target eax))
 520   (:info y)
 521   (:arg-types tagged-num (:constant fixnum))
 522   (:temporary (:sc signed-reg :offset eax-offset :target quo
 523                    :from :argument :to (:result 0)) eax)
 524   (:temporary (:sc any-reg :offset edx-offset :target rem
 525                    :from :eval :to (:result 1)) edx)
 526   (:temporary (:sc any-reg :from :eval :to :result) y-arg)
 527   (:results (quo :scs (any-reg))
 528             (rem :scs (any-reg)))
 529   (:result-types tagged-num tagged-num)
 530   (:note "inline fixnum arithmetic")
 531   (:vop-var vop)
 532   (:save-p :compute-only)
 533   (:generator 30
 534     (move eax x)
 535     (inst cqo)
 536     (if (typep y '(signed-byte 29))
 537         (inst mov y-arg (fixnumize y))
 538         (setf y-arg (register-inline-constant :qword (fixnumize y))))
 539     (inst idiv eax y-arg)
 540     (if (location= quo eax)
 541         (inst shl eax n-fixnum-tag-bits)
 542         (inst lea quo (make-ea :qword :index eax
 543                                :scale (ash 1 n-fixnum-tag-bits))))
 544     (move rem edx)))
 545
 546 (define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
 547   (:translate truncate)
 548   (:args (x :scs (unsigned-reg) :target eax)
 549          (y :scs (unsigned-reg signed-stack)))
 550   (:arg-types unsigned-num unsigned-num)
 551   (:temporary (:sc unsigned-reg :offset eax-offset :target quo
 552                    :from (:argument 0) :to (:result 0)) eax)
 553   (:temporary (:sc unsigned-reg :offset edx-offset :target rem
 554                    :from (:argument 0) :to (:result 1)) edx)
 555   (:results (quo :scs (unsigned-reg))
 556             (rem :scs (unsigned-reg)))
 557   (:result-types unsigned-num unsigned-num)
 558   (:note "inline (unsigned-byte 64) arithmetic")
 559   (:vop-var vop)
 560   (:save-p :compute-only)
 561   (:generator 33
 562     (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
 563       (if (sc-is y unsigned-reg)
 564           (inst test y y)  ; smaller instruction
 565           (inst cmp y 0))
 566       (inst jmp :eq zero))
 567     (move eax x)
 568     (inst xor edx edx)
 569     (inst div eax y)
 570     (move quo eax)
 571     (move rem edx)))
 572
 573 (define-vop (fast-truncate-c/unsigned=>unsigned fast-safe-arith-op)
 574   (:translate truncate)
 575   (:args (x :scs (unsigned-reg) :target eax))
 576   (:info y)
 577   (:arg-types unsigned-num (:constant (unsigned-byte 64)))
 578   (:temporary (:sc unsigned-reg :offset eax-offset :target quo
 579                    :from :argument :to (:result 0)) eax)
 580   (:temporary (:sc unsigned-reg :offset edx-offset :target rem
 581                    :from :eval :to (:result 1)) edx)
 582   (:temporary (:sc unsigned-reg :from :eval :to :result) y-arg)
 583   (:results (quo :scs (unsigned-reg))
 584             (rem :scs (unsigned-reg)))
 585   (:result-types unsigned-num unsigned-num)
 586   (:note "inline (unsigned-byte 64) arithmetic")
 587   (:vop-var vop)
 588   (:save-p :compute-only)
 589   (:generator 32
 590     (move eax x)
 591     (inst xor edx edx)
 592     (if (typep y '(unsigned-byte 31))
 593         (inst mov y-arg y)
 594         (setf y-arg (register-inline-constant :qword y)))
 595     (inst div eax y-arg)
 596     (move quo eax)
 597     (move rem edx)))
 598
 599 (define-vop (fast-truncate/signed=>signed fast-safe-arith-op)
 600   (:translate truncate)
 601   (:args (x :scs (signed-reg) :target eax)
 602          (y :scs (signed-reg signed-stack)))
 603   (:arg-types signed-num signed-num)
 604   (:temporary (:sc signed-reg :offset eax-offset :target quo
 605                    :from (:argument 0) :to (:result 0)) eax)
 606   (:temporary (:sc signed-reg :offset edx-offset :target rem
 607                    :from (:argument 0) :to (:result 1)) edx)
 608   (:results (quo :scs (signed-reg))
 609             (rem :scs (signed-reg)))
 610   (:result-types signed-num signed-num)
 611   (:note "inline (signed-byte 64) arithmetic")
 612   (:vop-var vop)
 613   (:save-p :compute-only)
 614   (:generator 33
 615     (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
 616       (if (sc-is y signed-reg)
 617           (inst test y y)  ; smaller instruction
 618           (inst cmp y 0))
 619       (inst jmp :eq zero))
 620     (move eax x)
 621     (inst cqo)
 622     (inst idiv eax y)
 623     (move quo eax)
 624     (move rem edx)))
 625
 626 (define-vop (fast-truncate-c/signed=>signed fast-safe-arith-op)
 627   (:translate truncate)
 628   (:args (x :scs (signed-reg) :target eax))
 629   (:info y)
 630   (:arg-types signed-num (:constant (signed-byte 64)))
 631   (:temporary (:sc signed-reg :offset eax-offset :target quo
 632                    :from :argument :to (:result 0)) eax)
 633   (:temporary (:sc signed-reg :offset edx-offset :target rem
 634                    :from :eval :to (:result 1)) edx)
 635   (:temporary (:sc signed-reg :from :eval :to :result) y-arg)
 636   (:results (quo :scs (signed-reg))
 637             (rem :scs (signed-reg)))
 638   (:result-types signed-num signed-num)
 639   (:note "inline (signed-byte 64) arithmetic")
 640   (:vop-var vop)
 641   (:save-p :compute-only)
 642   (:generator 32
 643     (move eax x)
 644     (inst cqo)
 645     (if (typep y '(signed-byte 32))
 646         (inst mov y-arg y)
 647         (setf y-arg (register-inline-constant :qword y)))
 648     (inst idiv eax y-arg)
 649     (move quo eax)
 650     (move rem edx)))
 651
 652
 653 \f
 654 ;;;; Shifting
 655 (define-vop (fast-ash-c/fixnum=>fixnum)
 656   (:translate ash)
 657   (:policy :fast-safe)
 658   (:args (number :scs (any-reg) :target result
 659                  :load-if (not (and (sc-is number any-reg control-stack)
 660                                     (sc-is result any-reg control-stack)
 661                                     (location= number result)))))
 662   (:info amount)
 663   (:arg-types tagged-num (:constant integer))
 664   (:results (result :scs (any-reg)
 665                     :load-if (not (and (sc-is number control-stack)
 666                                        (sc-is result control-stack)
 667                                        (location= number result)))))
 668   (:result-types tagged-num)
 669   (:note "inline ASH")
 670   (:variant nil)
 671   (:variant-vars modularp)
 672   (:generator 2
 673     (cond ((and (= amount 1) (not (location= number result)))
 674            (inst lea result (make-ea :qword :base number :index number)))
 675           ((and (= amount 2) (not (location= number result)))
 676            (inst lea result (make-ea :qword :index number :scale 4)))
 677           ((and (= amount 3) (not (location= number result)))
 678            (inst lea result (make-ea :qword :index number :scale 8)))
 679           (t
 680            (move result number)
 681            (cond ((< -64 amount 64)
 682                   ;; this code is used both in ASH and ASH-MODFX, so
 683                   ;; be careful
 684                   (if (plusp amount)
 685                       (inst shl result amount)
 686                       (progn
 687                         (inst sar result (- amount))
 688                         (inst and result (lognot fixnum-tag-mask)))))
 689                  ;; shifting left (zero fill)
 690                  ((plusp amount)
 691                   (unless modularp
 692                     (aver (not "Impossible: fixnum ASH should not be called with
 693 constant shift greater than word length")))
 694                   (if (sc-is result any-reg)
 695                       (zeroize result)
 696                       (inst mov result 0)))
 697                  ;; shifting right (sign fill)
 698                  (t (inst sar result 63)
 699                     (inst and result (lognot fixnum-tag-mask))))))))
 700
 701 (define-vop (fast-ash-left/fixnum=>fixnum)
 702   (:translate ash)
 703   (:args (number :scs (any-reg) :target result
 704                  :load-if (not (and (sc-is number control-stack)
 705                                     (sc-is result control-stack)
 706                                     (location= number result))))
 707          (amount :scs (unsigned-reg) :target ecx))
 708   (:arg-types tagged-num positive-fixnum)
 709   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
 710   (:results (result :scs (any-reg) :from (:argument 0)
 711                     :load-if (not (and (sc-is number control-stack)
 712                                        (sc-is result control-stack)
 713                                        (location= number result)))))
 714   (:result-types tagged-num)
 715   (:policy :fast-safe)
 716   (:note "inline ASH")
 717   (:generator 3
 718     (move result number)
 719     (move ecx amount)
 720     ;; The result-type ensures us that this shift will not overflow.
 721     (inst shl result :cl)))
 722
 723 (define-vop (fast-ash-c/signed=>signed)
 724   (:translate ash)
 725   (:policy :fast-safe)
 726   (:args (number :scs (signed-reg) :target result
 727                  :load-if (not (and (sc-is number signed-stack)
 728                                     (sc-is result signed-stack)
 729                                     (location= number result)))))
 730   (:info amount)
 731   (:arg-types signed-num (:constant integer))
 732   (:results (result :scs (signed-reg)
 733                     :load-if (not (and (sc-is number signed-stack)
 734                                        (sc-is result signed-stack)
 735                                        (location= number result)))))
 736   (:result-types signed-num)
 737   (:note "inline ASH")
 738   (:generator 3
 739     (cond ((and (= amount 1) (not (location= number result)))
 740            (inst lea result (make-ea :qword :base number :index number)))
 741           ((and (= amount 2) (not (location= number result)))
 742            (inst lea result (make-ea :qword :index number :scale 4)))
 743           ((and (= amount 3) (not (location= number result)))
 744            (inst lea result (make-ea :qword :index number :scale 8)))
 745           (t
 746            (move result number)
 747            (cond ((plusp amount) (inst shl result amount))
 748                  (t (inst sar result (min 63 (- amount)))))))))
 749
 750 (define-vop (fast-ash-c/unsigned=>unsigned)
 751   (:translate ash)
 752   (:policy :fast-safe)
 753   (:args (number :scs (unsigned-reg) :target result
 754                  :load-if (not (and (sc-is number unsigned-stack)
 755                                     (sc-is result unsigned-stack)
 756                                     (location= number result)))))
 757   (:info amount)
 758   (:arg-types unsigned-num (:constant integer))
 759   (:results (result :scs (unsigned-reg)
 760                     :load-if (not (and (sc-is number unsigned-stack)
 761                                        (sc-is result unsigned-stack)
 762                                        (location= number result)))))
 763   (:result-types unsigned-num)
 764   (:note "inline ASH")
 765   (:generator 3
 766     (cond ((and (= amount 1) (not (location= number result)))
 767            (inst lea result (make-ea :qword :base number :index number)))
 768           ((and (= amount 2) (not (location= number result)))
 769            (inst lea result (make-ea :qword :index number :scale 4)))
 770           ((and (= amount 3) (not (location= number result)))
 771            (inst lea result (make-ea :qword :index number :scale 8)))
 772           (t
 773            (move result number)
 774            (cond ((< -64 amount 64) ;; XXXX
 775                   ;; this code is used both in ASH and ASH-MOD32, so
 776                   ;; be careful
 777                   (if (plusp amount)
 778                       (inst shl result amount)
 779                       (inst shr result (- amount))))
 780                  (t (if (sc-is result unsigned-reg)
 781                         (zeroize result)
 782                         (inst mov result 0))))))))
 783
 784 (define-vop (fast-ash-left/signed=>signed)
 785   (:translate ash)
 786   (:args (number :scs (signed-reg) :target result
 787                  :load-if (not (and (sc-is number signed-stack)
 788                                     (sc-is result signed-stack)
 789                                     (location= number result))))
 790          (amount :scs (unsigned-reg) :target ecx))
 791   (:arg-types signed-num positive-fixnum)
 792   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
 793   (:results (result :scs (signed-reg) :from (:argument 0)
 794                     :load-if (not (and (sc-is number signed-stack)
 795                                        (sc-is result signed-stack)
 796                                        (location= number result)))))
 797   (:result-types signed-num)
 798   (:policy :fast-safe)
 799   (:note "inline ASH")
 800   (:generator 4
 801     (move result number)
 802     (move ecx amount)
 803     (inst shl result :cl)))
 804
 805 (define-vop (fast-ash-left/unsigned=>unsigned)
 806   (:translate ash)
 807   (:args (number :scs (unsigned-reg) :target result
 808                  :load-if (not (and (sc-is number unsigned-stack)
 809                                     (sc-is result unsigned-stack)
 810                                     (location= number result))))
 811          (amount :scs (unsigned-reg) :target ecx))
 812   (:arg-types unsigned-num positive-fixnum)
 813   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
 814   (:results (result :scs (unsigned-reg) :from (:argument 0)
 815                     :load-if (not (and (sc-is number unsigned-stack)
 816                                        (sc-is result unsigned-stack)
 817                                        (location= number result)))))
 818   (:result-types unsigned-num)
 819   (:policy :fast-safe)
 820   (:note "inline ASH")
 821   (:generator 4
 822     (move result number)
 823     (move ecx amount)
 824     (inst shl result :cl)))
 825
 826 (define-vop (fast-ash/signed=>signed)
 827   (:translate ash)
 828   (:policy :fast-safe)
 829   (:args (number :scs (signed-reg) :target result)
 830          (amount :scs (signed-reg) :target ecx))
 831   (:arg-types signed-num signed-num)
 832   (:results (result :scs (signed-reg) :from (:argument 0)))
 833   (:result-types signed-num)
 834   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
 835   (:note "inline ASH")
 836   (:generator 5
 837     (move result number)
 838     (move ecx amount)
 839     (inst or ecx ecx)
 840     (inst jmp :ns POSITIVE)
 841     (inst neg ecx)
 842     (inst cmp ecx 63)
 843     (inst jmp :be OKAY)
 844     (inst mov ecx 63)
 845     OKAY
 846     (inst sar result :cl)
 847     (inst jmp DONE)
 848
 849     POSITIVE
 850     ;; The result-type ensures us that this shift will not overflow.
 851     (inst shl result :cl)
 852
 853     DONE))
 854
 855 (define-vop (fast-ash/unsigned=>unsigned)
 856   (:translate ash)
 857   (:policy :fast-safe)
 858   (:args (number :scs (unsigned-reg) :target result)
 859          (amount :scs (signed-reg) :target ecx))
 860   (:arg-types unsigned-num signed-num)
 861   (:results (result :scs (unsigned-reg) :from (:argument 0)))
 862   (:result-types unsigned-num)
 863   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
 864   (:note "inline ASH")
 865   (:generator 5
 866     (move result number)
 867     (move ecx amount)
 868     (inst or ecx ecx)
 869     (inst jmp :ns POSITIVE)
 870     (inst neg ecx)
 871     (inst cmp ecx 63)
 872     (inst jmp :be OKAY)
 873     (zeroize result)
 874     (inst jmp DONE)
 875     OKAY
 876     (inst shr result :cl)
 877     (inst jmp DONE)
 878
 879     POSITIVE
 880     ;; The result-type ensures us that this shift will not overflow.
 881     (inst shl result :cl)
 882
 883     DONE))
 884
 885 (in-package "SB!C")
 886
 887 (defknown %lea (integer integer (member 1 2 4 8 16) (signed-byte 64))
 888   integer
 889   (foldable flushable movable))
 890
 891 (defoptimizer (%lea derive-type) ((base index scale disp))
 892   (when (and (constant-lvar-p scale)
 893              (constant-lvar-p disp))
 894     (let ((scale (lvar-value scale))
 895           (disp (lvar-value disp))
 896           (base-type (lvar-type base))
 897           (index-type (lvar-type index)))
 898       (when (and (numeric-type-p base-type)
 899                  (numeric-type-p index-type))
 900         (let ((base-lo (numeric-type-low base-type))
 901               (base-hi (numeric-type-high base-type))
 902               (index-lo (numeric-type-low index-type))
 903               (index-hi (numeric-type-high index-type)))
 904           (make-numeric-type :class 'integer
 905                              :complexp :real
 906                              :low (when (and base-lo index-lo)
 907                                     (+ base-lo (* index-lo scale) disp))
 908                              :high (when (and base-hi index-hi)
 909                                      (+ base-hi (* index-hi scale) disp))))))))
 910
 911 (defun %lea (base index scale disp)
 912   (+ base (* index scale) disp))
 913
 914 (in-package "SB!VM")
 915
 916 (define-vop (%lea/unsigned=>unsigned)
 917   (:translate %lea)
 918   (:policy :fast-safe)
 919   (:args (base :scs (unsigned-reg))
 920          (index :scs (unsigned-reg)))
 921   (:info scale disp)
 922   (:arg-types unsigned-num unsigned-num
 923               (:constant (member 1 2 4 8))
 924               (:constant (signed-byte 64)))
 925   (:results (r :scs (unsigned-reg)))
 926   (:result-types unsigned-num)
 927   (:generator 5
 928     (inst lea r (make-ea :qword :base base :index index
 929                          :scale scale :disp disp))))
 930
 931 (define-vop (%lea/signed=>signed)
 932   (:translate %lea)
 933   (:policy :fast-safe)
 934   (:args (base :scs (signed-reg))
 935          (index :scs (signed-reg)))
 936   (:info scale disp)
 937   (:arg-types signed-num signed-num
 938               (:constant (member 1 2 4 8))
 939               (:constant (signed-byte 64)))
 940   (:results (r :scs (signed-reg)))
 941   (:result-types signed-num)
 942   (:generator 4
 943     (inst lea r (make-ea :qword :base base :index index
 944                          :scale scale :disp disp))))
 945
 946 (define-vop (%lea/fixnum=>fixnum)
 947   (:translate %lea)
 948   (:policy :fast-safe)
 949   (:args (base :scs (any-reg))
 950          (index :scs (any-reg)))
 951   (:info scale disp)
 952   (:arg-types tagged-num tagged-num
 953               (:constant (member 1 2 4 8))
 954               (:constant (signed-byte 64)))
 955   (:results (r :scs (any-reg)))
 956   (:result-types tagged-num)
 957   (:generator 3
 958     (inst lea r (make-ea :qword :base base :index index
 959                          :scale scale :disp disp))))
 960
 961 ;;; FIXME: before making knowledge of this too public, it needs to be
 962 ;;; fixed so that it's actually _faster_ than the non-CMOV version; at
 963 ;;; least on my Celeron-XXX laptop, this version is marginally slower
 964 ;;; than the above version with branches.  -- CSR, 2003-09-04
 965 (define-vop (fast-cmov-ash/unsigned=>unsigned)
 966   (:translate ash)
 967   (:policy :fast-safe)
 968   (:args (number :scs (unsigned-reg) :target result)
 969          (amount :scs (signed-reg) :target ecx))
 970   (:arg-types unsigned-num signed-num)
 971   (:results (result :scs (unsigned-reg) :from (:argument 0)))
 972   (:result-types unsigned-num)
 973   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
 974   (:temporary (:sc any-reg :from (:eval 0) :to (:eval 1)) zero)
 975   (:note "inline ASH")
 976   (:guard (member :cmov *backend-subfeatures*))
 977   (:generator 4
 978     (move result number)
 979     (move ecx amount)
 980     (inst or ecx ecx)
 981     (inst jmp :ns POSITIVE)
 982     (inst neg ecx)
 983     (zeroize zero)
 984     (inst shr result :cl)
 985     (inst cmp ecx 63)
 986     (inst cmov :nbe result zero)
 987     (inst jmp DONE)
 988
 989     POSITIVE
 990     ;; The result-type ensures us that this shift will not overflow.
 991     (inst shl result :cl)
 992
 993     DONE))
 994 \f
 995 (define-vop (signed-byte-64-len)
 996   (:translate integer-length)
 997   (:note "inline (signed-byte 64) integer-length")
 998   (:policy :fast-safe)
 999   (:args (arg :scs (signed-reg) :target res))
1000   (:arg-types signed-num)
1001   (:results (res :scs (unsigned-reg)))
1002   (:result-types unsigned-num)
1003   (:generator 28
1004     (move res arg)
1005     (if (sc-is res unsigned-reg)
1006         (inst test res res)
1007         (inst cmp res 0))
1008     (inst jmp :ge POS)
1009     (inst not res)
1010     POS
1011     (inst bsr res res)
1012     (inst jmp :z ZERO)
1013     (inst inc res)
1014     (inst jmp DONE)
1015     ZERO
1016     (zeroize res)
1017     DONE))
1018
1019 (define-vop (unsigned-byte-64-len)
1020   (:translate integer-length)
1021   (:note "inline (unsigned-byte 64) integer-length")
1022   (:policy :fast-safe)
1023   (:args (arg :scs (unsigned-reg)))
1024   (:arg-types unsigned-num)
1025   (:results (res :scs (unsigned-reg)))
1026   (:result-types unsigned-num)
1027   (:generator 26
1028     (inst bsr res arg)
1029     (inst jmp :z ZERO)
1030     (inst inc res)
1031     (inst jmp DONE)
1032     ZERO
1033     (zeroize res)
1034     DONE))
1035
1036 (define-vop (unsigned-byte-64-count)
1037   (:translate logcount)
1038   (:note "inline (unsigned-byte 64) logcount")
1039   (:policy :fast-safe)
1040   (:args (arg :scs (unsigned-reg) :target result))
1041   (:arg-types unsigned-num)
1042   (:results (result :scs (unsigned-reg)))
1043   (:result-types positive-fixnum)
1044   (:temporary (:sc unsigned-reg) temp)
1045   (:temporary (:sc unsigned-reg) mask)
1046   (:generator 14
1047     ;; See the comments below for how the algorithm works. The tricks
1048     ;; used can be found for example in AMD's software optimization
1049     ;; guide or at "http://www.hackersdelight.org/HDcode/pop.cc" in the
1050     ;; function "pop1", for 32-bit words. The extension to 64 bits is
1051     ;; straightforward.
1052     ;; Calculate 2-bit sums. Note that the value of a two-digit binary
1053     ;; number is the sum of the right digit and twice the left digit.
1054     ;; Thus we can calculate the sum of the two digits by shifting the
1055     ;; left digit to the right position and doing a two-bit subtraction.
1056     ;; This subtraction will never create a borrow and thus can be made
1057     ;; on all 32 2-digit numbers at once.
1058     (move result arg)
1059     (move temp arg)
1060     (inst shr result 1)
1061     (inst mov mask #x5555555555555555)
1062     (inst and result mask)
1063     (inst sub temp result)
1064     ;; Calculate 4-bit sums by straightforward shift, mask and add.
1065     ;; Note that we shift the source operand of the MOV and not its
1066     ;; destination so that the SHR and the MOV can execute in the same
1067     ;; clock cycle.
1068     (inst mov result temp)
1069     (inst shr temp 2)
1070     (inst mov mask #x3333333333333333)
1071     (inst and result mask)
1072     (inst and temp mask)
1073     (inst add result temp)
1074     ;; Calculate 8-bit sums. Since each sum is at most 8, which fits
1075     ;; into 4 bits, we can apply the mask after the addition, saving one
1076     ;; instruction.
1077     (inst mov temp result)
1078     (inst shr result 4)
1079     (inst add result temp)
1080     (inst mov mask #x0f0f0f0f0f0f0f0f)
1081     (inst and result mask)
1082     ;; Add all 8 bytes at once by multiplying with #256r11111111.
1083     ;; We need to calculate only the lower 8 bytes of the product.
1084     ;; Of these the most significant byte contains the final result.
1085     ;; Note that there can be no overflow from one byte to the next
1086     ;; as the sum is at most 64 which needs only 7 bits.
1087     (inst mov mask #x0101010101010101)
1088     (inst imul result mask)
1089     (inst shr result 56)))
1090 \f
1091 ;;;; binary conditional VOPs
1092
1093 (define-vop (fast-conditional)
1094   (:conditional :e)
1095   (:info)
1096   (:effects)
1097   (:affected)
1098   (:policy :fast-safe))
1099
1100 ;;; constant variants are declared for 32 bits not 64 bits, because
1101 ;;; loading a 64 bit constant is silly
1102
1103 (define-vop (fast-conditional/fixnum fast-conditional)
1104   (:args (x :scs (any-reg)
1105             :load-if (not (and (sc-is x control-stack)
1106                                (sc-is y any-reg))))
1107          (y :scs (any-reg control-stack)))
1108   (:arg-types tagged-num tagged-num)
1109   (:note "inline fixnum comparison"))
1110
1111 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
1112   (:args (x :scs (any-reg)
1113             :load-if (or (not (typep y '(signed-byte 29)))
1114                          (not (sc-is x any-reg control-stack)))))
1115   (:arg-types tagged-num (:constant fixnum))
1116   (:info y))
1117
1118 (define-vop (fast-conditional/signed fast-conditional)
1119   (:args (x :scs (signed-reg)
1120             :load-if (not (and (sc-is x signed-stack)
1121                                (sc-is y signed-reg))))
1122          (y :scs (signed-reg signed-stack)))
1123   (:arg-types signed-num signed-num)
1124   (:note "inline (signed-byte 64) comparison"))
1125
1126 (define-vop (fast-conditional-c/signed fast-conditional/signed)
1127   (:args (x :scs (signed-reg)
1128             :load-if (or (not (typep y '(signed-byte 32)))
1129                          (not (sc-is x signed-reg signed-stack)))))
1130   (:arg-types signed-num (:constant (signed-byte 64)))
1131   (:info y))
1132
1133 (define-vop (fast-conditional/unsigned fast-conditional)
1134   (:args (x :scs (unsigned-reg)
1135             :load-if (not (and (sc-is x unsigned-stack)
1136                                (sc-is y unsigned-reg))))
1137          (y :scs (unsigned-reg unsigned-stack)))
1138   (:arg-types unsigned-num unsigned-num)
1139   (:note "inline (unsigned-byte 64) comparison"))
1140
1141 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
1142   (:args (x :scs (unsigned-reg)
1143             :load-if (or (not (typep y '(unsigned-byte 31)))
1144                          (not (sc-is x unsigned-reg unsigned-stack)))))
1145   (:arg-types unsigned-num (:constant (unsigned-byte 64)))
1146   (:info y))
1147
1148 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
1149              `(progn
1150                 ,@(mapcar
1151                    (lambda (suffix cost signed)
1152                      `(define-vop (;; FIXME: These could be done more
1153                                    ;; cleanly with SYMBOLICATE.
1154                                    ,(intern (format nil "~:@(FAST-IF-~A~A~)"
1155                                                     tran suffix))
1156                                    ,(intern
1157                                      (format nil "~:@(FAST-CONDITIONAL~A~)"
1158                                              suffix)))
1159                         (:translate ,tran)
1160                         (:conditional ,(if signed cond unsigned))
1161                         (:generator ,cost
1162                                     (inst cmp x
1163                                           ,(case suffix
1164                                              (-c/fixnum
1165                                                 `(if (typep y '(signed-byte 29))
1166                                                      (fixnumize y)
1167                                                      (register-inline-constant
1168                                                       :qword (fixnumize y))))
1169                                              (-c/signed
1170                                                 `(if (typep y '(signed-byte 32))
1171                                                      y
1172                                                      (register-inline-constant
1173                                                       :qword y)))
1174                                              (-c/unsigned
1175                                                 `(if (typep y '(unsigned-byte 31))
1176                                                      y
1177                                                      (register-inline-constant
1178                                                       :qword y)))
1179                                              (t 'y))))))
1180                    '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
1181 ;                  '(/fixnum  /signed  /unsigned)
1182                    '(4 3 6 5 6 5)
1183                    '(t t t t nil nil)))))
1184
1185   (define-conditional-vop < :l :b :ge :ae)
1186   (define-conditional-vop > :g :a :le :be))
1187
1188 (define-vop (fast-if-eql/signed fast-conditional/signed)
1189   (:translate eql)
1190   (:generator 6
1191     (inst cmp x y)))
1192
1193 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
1194   (:translate eql)
1195   (:generator 5
1196     (cond ((and (sc-is x signed-reg) (zerop y))
1197            (inst test x x))  ; smaller instruction
1198           ((typep y '(signed-byte 32))
1199            (inst cmp x y))
1200           (t
1201            (inst cmp x (register-inline-constant :qword y))))))
1202
1203 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
1204   (:translate eql)
1205   (:generator 6
1206     (inst cmp x y)))
1207
1208 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
1209   (:translate eql)
1210   (:generator 5
1211     (cond ((and (sc-is x unsigned-reg) (zerop y))
1212            (inst test x x))  ; smaller instruction
1213           ((typep y '(unsigned-byte 31))
1214            (inst cmp x y))
1215           (t
1216            (inst cmp x (register-inline-constant :qword y))))))
1217
1218 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
1219 ;;; known fixnum.
1220
1221 ;;; These versions specify a fixnum restriction on their first arg. We have
1222 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
1223 ;;; the first arg and a higher cost. The reason for doing this is to prevent
1224 ;;; fixnum specific operations from being used on word integers, spuriously
1225 ;;; consing the argument.
1226
1227 (define-vop (fast-eql/fixnum fast-conditional)
1228   (:args (x :scs (any-reg)
1229             :load-if (not (and (sc-is x control-stack)
1230                                (sc-is y any-reg))))
1231          (y :scs (any-reg control-stack)))
1232   (:arg-types tagged-num tagged-num)
1233   (:note "inline fixnum comparison")
1234   (:translate eql)
1235   (:generator 4
1236     (inst cmp x y)))
1237
1238 (define-vop (generic-eql/fixnum fast-eql/fixnum)
1239   (:args (x :scs (any-reg descriptor-reg)
1240             :load-if (not (and (sc-is x control-stack)
1241                                (sc-is y any-reg))))
1242          (y :scs (any-reg control-stack)))
1243   (:arg-types * tagged-num)
1244   (:variant-cost 7))
1245
1246 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
1247   (:args (x :scs (any-reg)
1248             :load-if (or (not (typep y '(signed-byte 29)))
1249                          (not (sc-is x any-reg descriptor-reg control-stack)))))
1250   (:arg-types tagged-num (:constant fixnum))
1251   (:info y)
1252   (:translate eql)
1253   (:generator 2
1254     (cond ((and (sc-is x any-reg descriptor-reg) (zerop y))
1255            (inst test x x))  ; smaller instruction
1256           ((typep y '(signed-byte 29))
1257            (inst cmp x (fixnumize y)))
1258           (t
1259            (inst cmp x (register-inline-constant :qword (fixnumize y)))))))
1260
1261 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
1262   (:args (x :scs (any-reg descriptor-reg)))
1263   (:arg-types * (:constant fixnum))
1264   (:variant-cost 6))
1265 \f
1266 ;;;; 32-bit logical operations
1267
1268 ;;; Only the lower 6 bits of the shift amount are significant.
1269 (define-vop (shift-towards-someplace)
1270   (:policy :fast-safe)
1271   (:args (num :scs (unsigned-reg) :target r)
1272          (amount :scs (signed-reg) :target ecx))
1273   (:arg-types unsigned-num tagged-num)
1274   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
1275   (:results (r :scs (unsigned-reg) :from (:argument 0)))
1276   (:result-types unsigned-num))
1277
1278 (define-vop (shift-towards-start shift-towards-someplace)
1279   (:translate shift-towards-start)
1280   (:note "SHIFT-TOWARDS-START")
1281   (:generator 1
1282     (move r num)
1283     (move ecx amount)
1284     (inst shr r :cl)))
1285
1286 (define-vop (shift-towards-end shift-towards-someplace)
1287   (:translate shift-towards-end)
1288   (:note "SHIFT-TOWARDS-END")
1289   (:generator 1
1290     (move r num)
1291     (move ecx amount)
1292     (inst shl r :cl)))
1293 \f
1294 ;;;; Modular functions
1295
1296 (defmacro define-mod-binop ((name prototype) function)
1297   `(define-vop (,name ,prototype)
1298        (:args (x :target r :scs (unsigned-reg signed-reg)
1299                  :load-if (not (and (or (sc-is x unsigned-stack)
1300                                         (sc-is x signed-stack))
1301                                     (or (sc-is y unsigned-reg)
1302                                         (sc-is y signed-reg))
1303                                     (or (sc-is r unsigned-stack)
1304                                         (sc-is r signed-stack))
1305                                     (location= x r))))
1306               (y :scs (unsigned-reg signed-reg unsigned-stack signed-stack)))
1307      (:arg-types untagged-num untagged-num)
1308      (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1309                   :load-if (not (and (or (sc-is x unsigned-stack)
1310                                          (sc-is x signed-stack))
1311                                      (or (sc-is y unsigned-reg)
1312                                          (sc-is y unsigned-reg))
1313                                      (or (sc-is r unsigned-stack)
1314                                          (sc-is r unsigned-stack))
1315                                      (location= x r)))))
1316      (:result-types unsigned-num)
1317      (:translate ,function)))
1318 (defmacro define-mod-binop-c ((name prototype) function)
1319   `(define-vop (,name ,prototype)
1320        (:args (x :target r :scs (unsigned-reg signed-reg)
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 signed-stack))
1325                                     (location= x r)
1326                                     (typep y '(signed-byte 32))))))
1327      (:info y)
1328      (:arg-types untagged-num (:constant (or (unsigned-byte 64) (signed-byte 64))))
1329      (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1330                   :load-if (not (and (or (sc-is x unsigned-stack)
1331                                          (sc-is x signed-stack))
1332                                      (or (sc-is r unsigned-stack)
1333                                          (sc-is r unsigned-stack))
1334                                      (location= x r)))))
1335      (:result-types unsigned-num)
1336      (:translate ,function)))
1337
1338 (macrolet ((def (name -c-p)
1339              (let ((fun64 (intern (format nil "~S-MOD64" name)))
1340                    (vopu (intern (format nil "FAST-~S/UNSIGNED=>UNSIGNED" name)))
1341                    (vopcu (intern (format nil "FAST-~S-C/UNSIGNED=>UNSIGNED" name)))
1342                    (vopf (intern (format nil "FAST-~S/FIXNUM=>FIXNUM" name)))
1343                    (vopcf (intern (format nil "FAST-~S-C/FIXNUM=>FIXNUM" name)))
1344                    (vop64u (intern (format nil "FAST-~S-MOD64/WORD=>UNSIGNED" name)))
1345                    (vop64f (intern (format nil "FAST-~S-MOD64/FIXNUM=>FIXNUM" name)))
1346                    (vop64cu (intern (format nil "FAST-~S-MOD64-C/WORD=>UNSIGNED" name)))
1347                    (vop64cf (intern (format nil "FAST-~S-MOD64-C/FIXNUM=>FIXNUM" name)))
1348                    (funfx (intern (format nil "~S-MODFX" name)))
1349                    (vopfxf (intern (format nil "FAST-~S-MODFX/FIXNUM=>FIXNUM" name)))
1350                    (vopfxcf (intern (format nil "FAST-~S-MODFX-C/FIXNUM=>FIXNUM" name))))
1351                `(progn
1352                   (define-modular-fun ,fun64 (x y) ,name :untagged nil 64)
1353                   (define-modular-fun ,funfx (x y) ,name :tagged t
1354                                       #.(- n-word-bits n-fixnum-tag-bits))
1355                   (define-mod-binop (,vop64u ,vopu) ,fun64)
1356                   (define-vop (,vop64f ,vopf) (:translate ,fun64))
1357                   (define-vop (,vopfxf ,vopf) (:translate ,funfx))
1358                   ,@(when -c-p
1359                       `((define-mod-binop-c (,vop64cu ,vopcu) ,fun64)
1360                         (define-vop (,vopfxcf ,vopcf) (:translate ,funfx))))))))
1361   (def + t)
1362   (def - t)
1363   (def * t))
1364
1365 (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
1366              fast-ash-c/unsigned=>unsigned)
1367   (:translate ash-left-mod64))
1368 (define-vop (fast-ash-left-mod64/unsigned=>unsigned
1369              fast-ash-left/unsigned=>unsigned))
1370 (deftransform ash-left-mod64 ((integer count)
1371                               ((unsigned-byte 64) (unsigned-byte 6)))
1372   (when (sb!c::constant-lvar-p count)
1373     (sb!c::give-up-ir1-transform))
1374   '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
1375
1376 (define-vop (fast-ash-left-modfx-c/fixnum=>fixnum
1377              fast-ash-c/fixnum=>fixnum)
1378   (:variant :modular)
1379   (:translate ash-left-modfx))
1380 (define-vop (fast-ash-left-modfx/fixnum=>fixnum
1381              fast-ash-left/fixnum=>fixnum))
1382 (deftransform ash-left-modfx ((integer count)
1383                               (fixnum (unsigned-byte 6)))
1384   (when (sb!c::constant-lvar-p count)
1385     (sb!c::give-up-ir1-transform))
1386   '(%primitive fast-ash-left-modfx/fixnum=>fixnum integer count))
1387
1388 (in-package "SB!C")
1389
1390 (defknown sb!vm::%lea-mod64 (integer integer (member 1 2 4 8) (signed-byte 64))
1391   (unsigned-byte 64)
1392   (foldable flushable movable))
1393 (defknown sb!vm::%lea-modfx (integer integer (member 1 2 4 8) (signed-byte 64))
1394   fixnum
1395   (foldable flushable movable))
1396
1397 (define-modular-fun-optimizer %lea ((base index scale disp) :untagged nil :width width)
1398   (when (and (<= width 64)
1399              (constant-lvar-p scale)
1400              (constant-lvar-p disp))
1401     (cut-to-width base :untagged width nil)
1402     (cut-to-width index :untagged width nil)
1403     'sb!vm::%lea-mod64))
1404 (define-modular-fun-optimizer %lea ((base index scale disp) :tagged t :width width)
1405   (when (and (<= width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
1406              (constant-lvar-p scale)
1407              (constant-lvar-p disp))
1408     (cut-to-width base :tagged width t)
1409     (cut-to-width index :tagged width t)
1410     'sb!vm::%lea-modfx))
1411
1412 #+sb-xc-host
1413 (progn
1414   (defun sb!vm::%lea-mod64 (base index scale disp)
1415     (ldb (byte 64 0) (%lea base index scale disp)))
1416   (defun sb!vm::%lea-modfx (base index scale disp)
1417     (mask-signed-field (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)
1418                        (%lea base index scale disp))))
1419 #-sb-xc-host
1420 (progn
1421   (defun sb!vm::%lea-mod64 (base index scale disp)
1422     (let ((base (logand base #xffffffffffffffff))
1423           (index (logand index #xffffffffffffffff)))
1424       ;; can't use modular version of %LEA, as we only have VOPs for
1425       ;; constant SCALE and DISP.
1426       (ldb (byte 64 0) (+ base (* index scale) disp))))
1427   (defun sb!vm::%lea-modfx (base index scale disp)
1428     (let* ((fixnum-width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
1429            (base (mask-signed-field fixnum-width base))
1430            (index (mask-signed-field fixnum-width index)))
1431       ;; can't use modular version of %LEA, as we only have VOPs for
1432       ;; constant SCALE and DISP.
1433       (mask-signed-field fixnum-width (+ base (* index scale) disp)))))
1434
1435 (in-package "SB!VM")
1436
1437 (define-vop (%lea-mod64/unsigned=>unsigned
1438              %lea/unsigned=>unsigned)
1439   (:translate %lea-mod64))
1440 (define-vop (%lea-modfx/fixnum=>fixnum
1441              %lea/fixnum=>fixnum)
1442   (:translate %lea-modfx))
1443
1444 ;;; logical operations
1445 (define-modular-fun lognot-mod64 (x) lognot :untagged nil 64)
1446 (define-vop (lognot-mod64/unsigned=>unsigned)
1447   (:translate lognot-mod64)
1448   (:args (x :scs (unsigned-reg unsigned-stack) :target r
1449             :load-if (not (and (sc-is x unsigned-stack)
1450                                (sc-is r unsigned-stack)
1451                                (location= x r)))))
1452   (:arg-types unsigned-num)
1453   (:results (r :scs (unsigned-reg)
1454                :load-if (not (and (sc-is x unsigned-stack)
1455                                   (sc-is r unsigned-stack)
1456                                   (location= x r)))))
1457   (:result-types unsigned-num)
1458   (:policy :fast-safe)
1459   (:generator 1
1460     (move r x)
1461     (inst not r)))
1462
1463 (define-source-transform logeqv (&rest args)
1464   (if (oddp (length args))
1465       `(logxor ,@args)
1466       `(lognot (logxor ,@args))))
1467 (define-source-transform logandc1 (x y)
1468   `(logand (lognot ,x) ,y))
1469 (define-source-transform logandc2 (x y)
1470   `(logand ,x (lognot ,y)))
1471 (define-source-transform logorc1 (x y)
1472   `(logior (lognot ,x) ,y))
1473 (define-source-transform logorc2 (x y)
1474   `(logior ,x (lognot ,y)))
1475 (define-source-transform lognor (x y)
1476   `(lognot (logior ,x ,y)))
1477 (define-source-transform lognand (x y)
1478   `(lognot (logand ,x ,y)))
1479 \f
1480 ;;;; bignum stuff
1481
1482 (define-vop (bignum-length get-header-data)
1483   (:translate sb!bignum:%bignum-length)
1484   (:policy :fast-safe))
1485
1486 (define-vop (bignum-set-length set-header-data)
1487   (:translate sb!bignum:%bignum-set-length)
1488   (:policy :fast-safe))
1489
1490 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
1491   (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
1492 (define-full-reffer+offset bignum--ref-with-offset * bignum-digits-offset
1493   other-pointer-lowtag (unsigned-reg) unsigned-num
1494   sb!bignum:%bignum-ref-with-offset)
1495 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
1496   (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
1497
1498 (define-vop (digit-0-or-plus)
1499   (:translate sb!bignum:%digit-0-or-plusp)
1500   (:policy :fast-safe)
1501   (:args (digit :scs (unsigned-reg)))
1502   (:arg-types unsigned-num)
1503   (:conditional :ns)
1504   (:generator 3
1505     (inst or digit digit)))
1506
1507
1508 ;;; For add and sub with carry the sc of carry argument is any-reg so
1509 ;;; that it may be passed as a fixnum or word and thus may be 0, 1, or
1510 ;;; 8. This is easy to deal with and may save a fixnum-word
1511 ;;; conversion.
1512 (define-vop (add-w/carry)
1513   (:translate sb!bignum:%add-with-carry)
1514   (:policy :fast-safe)
1515   (:args (a :scs (unsigned-reg) :target result)
1516          (b :scs (unsigned-reg unsigned-stack) :to :eval)
1517          (c :scs (any-reg) :target temp))
1518   (:arg-types unsigned-num unsigned-num positive-fixnum)
1519   (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
1520   (:results (result :scs (unsigned-reg) :from (:argument 0))
1521             (carry :scs (unsigned-reg)))
1522   (:result-types unsigned-num positive-fixnum)
1523   (:generator 4
1524     (move result a)
1525     (move temp c)
1526     (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
1527     (inst adc result b)
1528     (inst mov carry 0)
1529     (inst adc carry carry)))
1530
1531 ;;; Note: the borrow is 1 for no borrow and 0 for a borrow, the opposite
1532 ;;; of the x86-64 convention.
1533 (define-vop (sub-w/borrow)
1534   (:translate sb!bignum:%subtract-with-borrow)
1535   (:policy :fast-safe)
1536   (:args (a :scs (unsigned-reg) :to :eval :target result)
1537          (b :scs (unsigned-reg unsigned-stack) :to :result)
1538          (c :scs (any-reg control-stack)))
1539   (:arg-types unsigned-num unsigned-num positive-fixnum)
1540   (:results (result :scs (unsigned-reg) :from :eval)
1541             (borrow :scs (unsigned-reg)))
1542   (:result-types unsigned-num positive-fixnum)
1543   (:generator 5
1544     (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
1545     (move result a)
1546     (inst sbb result b)
1547     (inst mov borrow 1)
1548     (inst sbb borrow 0)))
1549
1550
1551 (define-vop (bignum-mult-and-add-3-arg)
1552   (:translate sb!bignum:%multiply-and-add)
1553   (:policy :fast-safe)
1554   (:args (x :scs (unsigned-reg) :target eax)
1555          (y :scs (unsigned-reg unsigned-stack))
1556          (carry-in :scs (unsigned-reg unsigned-stack)))
1557   (:arg-types unsigned-num unsigned-num unsigned-num)
1558   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1559                    :to (:result 1) :target lo) eax)
1560   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1561                    :to (:result 0) :target hi) edx)
1562   (:results (hi :scs (unsigned-reg))
1563             (lo :scs (unsigned-reg)))
1564   (:result-types unsigned-num unsigned-num)
1565   (:generator 20
1566     (move eax x)
1567     (inst mul eax y)
1568     (inst add eax carry-in)
1569     (inst adc edx 0)
1570     (move hi edx)
1571     (move lo eax)))
1572
1573 (define-vop (bignum-mult-and-add-4-arg)
1574   (:translate sb!bignum:%multiply-and-add)
1575   (:policy :fast-safe)
1576   (:args (x :scs (unsigned-reg) :target eax)
1577          (y :scs (unsigned-reg unsigned-stack))
1578          (prev :scs (unsigned-reg unsigned-stack))
1579          (carry-in :scs (unsigned-reg unsigned-stack)))
1580   (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1581   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1582                    :to (:result 1) :target lo) eax)
1583   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1584                    :to (:result 0) :target hi) edx)
1585   (:results (hi :scs (unsigned-reg))
1586             (lo :scs (unsigned-reg)))
1587   (:result-types unsigned-num unsigned-num)
1588   (:generator 20
1589     (move eax x)
1590     (inst mul eax y)
1591     (inst add eax prev)
1592     (inst adc edx 0)
1593     (inst add eax carry-in)
1594     (inst adc edx 0)
1595     (move hi edx)
1596     (move lo eax)))
1597
1598
1599 (define-vop (bignum-mult)
1600   (:translate sb!bignum:%multiply)
1601   (:policy :fast-safe)
1602   (:args (x :scs (unsigned-reg) :target eax)
1603          (y :scs (unsigned-reg unsigned-stack)))
1604   (:arg-types unsigned-num unsigned-num)
1605   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1606                    :to (:result 1) :target lo) eax)
1607   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1608                    :to (:result 0) :target hi) edx)
1609   (:results (hi :scs (unsigned-reg))
1610             (lo :scs (unsigned-reg)))
1611   (:result-types unsigned-num unsigned-num)
1612   (:generator 20
1613     (move eax x)
1614     (inst mul eax y)
1615     (move hi edx)
1616     (move lo eax)))
1617
1618 #!+multiply-high-vops
1619 (define-vop (mulhi)
1620   (:translate sb!kernel:%multiply-high)
1621   (:policy :fast-safe)
1622   (:args (x :scs (unsigned-reg) :target eax)
1623          (y :scs (unsigned-reg unsigned-stack)))
1624   (:arg-types unsigned-num unsigned-num)
1625   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0))
1626               eax)
1627   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1628                    :to (:result 0) :target hi) edx)
1629   (:results (hi :scs (unsigned-reg)))
1630   (:result-types unsigned-num)
1631   (:generator 20
1632     (move eax x)
1633     (inst mul eax y)
1634     (move hi edx)))
1635
1636 #!+multiply-high-vops
1637 (define-vop (mulhi/fx)
1638   (:translate sb!kernel:%multiply-high)
1639   (:policy :fast-safe)
1640   (:args (x :scs (any-reg) :target eax)
1641          (y :scs (unsigned-reg unsigned-stack)))
1642   (:arg-types positive-fixnum unsigned-num)
1643   (:temporary (:sc any-reg :offset eax-offset :from (:argument 0)) eax)
1644   (:temporary (:sc any-reg :offset edx-offset :from (:argument 1)
1645                    :to (:result 0) :target hi) edx)
1646   (:results (hi :scs (any-reg)))
1647   (:result-types positive-fixnum)
1648   (:generator 15
1649     (move eax x)
1650     (inst mul eax y)
1651     (move hi edx)
1652     (inst and hi (lognot fixnum-tag-mask))))
1653
1654 (define-vop (bignum-lognot lognot-mod64/unsigned=>unsigned)
1655   (:translate sb!bignum:%lognot))
1656
1657 (define-vop (fixnum-to-digit)
1658   (:translate sb!bignum:%fixnum-to-digit)
1659   (:policy :fast-safe)
1660   (:args (fixnum :scs (any-reg control-stack) :target digit))
1661   (:arg-types tagged-num)
1662   (:results (digit :scs (unsigned-reg)
1663                    :load-if (not (and (sc-is fixnum control-stack)
1664                                       (sc-is digit unsigned-stack)
1665                                       (location= fixnum digit)))))
1666   (:result-types unsigned-num)
1667   (:generator 1
1668     (move digit fixnum)
1669     (inst sar digit n-fixnum-tag-bits)))
1670
1671 (define-vop (bignum-floor)
1672   (:translate sb!bignum:%bigfloor)
1673   (:policy :fast-safe)
1674   (:args (div-high :scs (unsigned-reg) :target edx)
1675          (div-low :scs (unsigned-reg) :target eax)
1676          (divisor :scs (unsigned-reg unsigned-stack)))
1677   (:arg-types unsigned-num unsigned-num unsigned-num)
1678   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
1679                    :to (:result 0) :target quo) eax)
1680   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
1681                    :to (:result 1) :target rem) edx)
1682   (:results (quo :scs (unsigned-reg))
1683             (rem :scs (unsigned-reg)))
1684   (:result-types unsigned-num unsigned-num)
1685   (:generator 300
1686     (move edx div-high)
1687     (move eax div-low)
1688     (inst div eax divisor)
1689     (move quo eax)
1690     (move rem edx)))
1691
1692 (define-vop (signify-digit)
1693   (:translate sb!bignum:%fixnum-digit-with-correct-sign)
1694   (:policy :fast-safe)
1695   (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
1696   (:arg-types unsigned-num)
1697   (:results (res :scs (any-reg signed-reg)
1698                  :load-if (not (and (sc-is digit unsigned-stack)
1699                                     (sc-is res control-stack signed-stack)
1700                                     (location= digit res)))))
1701   (:result-types signed-num)
1702   (:generator 1
1703     (move res digit)
1704     (when (sc-is res any-reg control-stack)
1705       (inst shl res n-fixnum-tag-bits))))
1706
1707 (define-vop (digit-ashr)
1708   (:translate sb!bignum:%ashr)
1709   (:policy :fast-safe)
1710   (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
1711          (count :scs (unsigned-reg) :target ecx))
1712   (:arg-types unsigned-num positive-fixnum)
1713   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
1714   (:results (result :scs (unsigned-reg) :from (:argument 0)
1715                     :load-if (not (and (sc-is result unsigned-stack)
1716                                        (location= digit result)))))
1717   (:result-types unsigned-num)
1718   (:generator 2
1719     (move result digit)
1720     (move ecx count)
1721     (inst sar result :cl)))
1722
1723 (define-vop (digit-ashr/c)
1724   (:translate sb!bignum:%ashr)
1725   (:policy :fast-safe)
1726   (:args (digit :scs (unsigned-reg unsigned-stack) :target result))
1727   (:arg-types unsigned-num (:constant (integer 0 63)))
1728   (:info count)
1729   (:results (result :scs (unsigned-reg) :from (:argument 0)
1730                     :load-if (not (and (sc-is result unsigned-stack)
1731                                        (location= digit result)))))
1732   (:result-types unsigned-num)
1733   (:generator 1
1734     (move result digit)
1735     (inst sar result count)))
1736
1737 (define-vop (digit-lshr digit-ashr)
1738   (:translate sb!bignum:%digit-logical-shift-right)
1739   (:generator 1
1740     (move result digit)
1741     (move ecx count)
1742     (inst shr result :cl)))
1743
1744 (define-vop (digit-ashl digit-ashr)
1745   (:translate sb!bignum:%ashl)
1746   (:generator 1
1747     (move result digit)
1748     (move ecx count)
1749     (inst shl result :cl)))
1750 \f
1751 ;;;; static functions
1752
1753 (define-static-fun two-arg-/ (x y) :translate /)
1754
1755 (define-static-fun two-arg-gcd (x y) :translate gcd)
1756 (define-static-fun two-arg-lcm (x y) :translate lcm)
1757
1758 (define-static-fun two-arg-and (x y) :translate logand)
1759 (define-static-fun two-arg-ior (x y) :translate logior)
1760 (define-static-fun two-arg-xor (x y) :translate logxor)
1761
1762
1763 (in-package "SB!C")
1764
1765 (defun *-transformer (y)
1766   (cond
1767     ((= y (ash 1 (integer-length y)))
1768      ;; there's a generic transform for y = 2^k
1769      (give-up-ir1-transform))
1770     ((member y '(3 5 9))
1771      ;; we can do these multiplications directly using LEA
1772      `(%lea x x ,(1- y) 0))
1773     (t
1774      ;; A normal 64-bit multiplication takes 4 cycles on Athlon 64/Opteron.
1775      ;; Optimizing multiplications (other than the above cases) to
1776      ;; shifts/adds/leas gives a maximum improvement of 1 cycle, but requires
1777      ;; quite a lot of hairy code.
1778      (give-up-ir1-transform))))
1779
1780 (deftransform * ((x y)
1781                  ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1782                  (unsigned-byte 64))
1783   "recode as leas, shifts and adds"
1784   (let ((y (lvar-value y)))
1785     (*-transformer y)))
1786 (deftransform sb!vm::*-mod64
1787     ((x y) ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1788      (unsigned-byte 64))
1789   "recode as leas, shifts and adds"
1790   (let ((y (lvar-value y)))
1791     (*-transformer y)))
1792
1793 (deftransform * ((x y)
1794                  (fixnum (constant-arg (unsigned-byte 64)))
1795                  fixnum)
1796   "recode as leas, shifts and adds"
1797   (let ((y (lvar-value y)))
1798     (*-transformer y)))
1799 (deftransform sb!vm::*-modfx
1800     ((x y) (fixnum (constant-arg (unsigned-byte 64)))
1801      fixnum)
1802   "recode as leas, shifts and adds"
1803   (let ((y (lvar-value y)))
1804     (*-transformer y)))