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