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     (if (sc-is res unsigned-reg)
1016         (inst test res res)
1017         (inst cmp res 0))
1018     (inst jmp :ge POS)
1019     (inst not res)
1020     POS
1021     (inst bsr res res)
1022     (inst jmp :z ZERO)
1023     (inst inc res)
1024     (inst jmp DONE)
1025     ZERO
1026     (zeroize res)
1027     DONE))
1028
1029 (define-vop (unsigned-byte-64-len)
1030   (:translate integer-length)
1031   (:note "inline (unsigned-byte 64) integer-length")
1032   (:policy :fast-safe)
1033   (:args (arg :scs (unsigned-reg)))
1034   (:arg-types unsigned-num)
1035   (:results (res :scs (unsigned-reg)))
1036   (:result-types unsigned-num)
1037   (:generator 26
1038     (inst bsr res arg)
1039     (inst jmp :z ZERO)
1040     (inst inc res)
1041     (inst jmp DONE)
1042     ZERO
1043     (zeroize res)
1044     DONE))
1045
1046 (define-vop (unsigned-byte-64-count)
1047   (:translate logcount)
1048   (:note "inline (unsigned-byte 64) logcount")
1049   (:policy :fast-safe)
1050   (:args (arg :scs (unsigned-reg) :target result))
1051   (:arg-types unsigned-num)
1052   (:results (result :scs (unsigned-reg)))
1053   (:result-types positive-fixnum)
1054   (:temporary (:sc unsigned-reg) temp)
1055   (:temporary (:sc unsigned-reg) mask)
1056   (:generator 14
1057     ;; See the comments below for how the algorithm works. The tricks
1058     ;; used can be found for example in AMD's software optimization
1059     ;; guide or at "http://www.hackersdelight.org/HDcode/pop.cc" in the
1060     ;; function "pop1", for 32-bit words. The extension to 64 bits is
1061     ;; straightforward.
1062     ;; Calculate 2-bit sums. Note that the value of a two-digit binary
1063     ;; number is the sum of the right digit and twice the left digit.
1064     ;; Thus we can calculate the sum of the two digits by shifting the
1065     ;; left digit to the right position and doing a two-bit subtraction.
1066     ;; This subtraction will never create a borrow and thus can be made
1067     ;; on all 32 2-digit numbers at once.
1068     (move result arg)
1069     (move temp arg)
1070     (inst shr result 1)
1071     (inst mov mask #x5555555555555555)
1072     (inst and result mask)
1073     (inst sub temp result)
1074     ;; Calculate 4-bit sums by straightforward shift, mask and add.
1075     ;; Note that we shift the source operand of the MOV and not its
1076     ;; destination so that the SHR and the MOV can execute in the same
1077     ;; clock cycle.
1078     (inst mov result temp)
1079     (inst shr temp 2)
1080     (inst mov mask #x3333333333333333)
1081     (inst and result mask)
1082     (inst and temp mask)
1083     (inst add result temp)
1084     ;; Calculate 8-bit sums. Since each sum is at most 8, which fits
1085     ;; into 4 bits, we can apply the mask after the addition, saving one
1086     ;; instruction.
1087     (inst mov temp result)
1088     (inst shr result 4)
1089     (inst add result temp)
1090     (inst mov mask #x0f0f0f0f0f0f0f0f)
1091     (inst and result mask)
1092     ;; Add all 8 bytes at once by multiplying with #256r11111111.
1093     ;; We need to calculate only the lower 8 bytes of the product.
1094     ;; Of these the most significant byte contains the final result.
1095     ;; Note that there can be no overflow from one byte to the next
1096     ;; as the sum is at most 64 which needs only 7 bits.
1097     (inst mov mask #x0101010101010101)
1098     (inst imul result mask)
1099     (inst shr result 56)))
1100 \f
1101 ;;;; binary conditional VOPs
1102
1103 (define-vop (fast-conditional)
1104   (:conditional :e)
1105   (:info)
1106   (:effects)
1107   (:affected)
1108   (:policy :fast-safe))
1109
1110 ;;; constant variants are declared for 32 bits not 64 bits, because
1111 ;;; loading a 64 bit constant is silly
1112
1113 (define-vop (fast-conditional/fixnum fast-conditional)
1114   (:args (x :scs (any-reg)
1115             :load-if (not (and (sc-is x control-stack)
1116                                (sc-is y any-reg))))
1117          (y :scs (any-reg control-stack)))
1118   (:arg-types tagged-num tagged-num)
1119   (:note "inline fixnum comparison"))
1120
1121 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
1122   (:args (x :scs (any-reg)
1123             :load-if (or (not (typep y 'short-tagged-num))
1124                          (not (sc-is x any-reg control-stack)))))
1125   (:arg-types tagged-num (:constant fixnum))
1126   (:info y))
1127
1128 (define-vop (fast-conditional/signed fast-conditional)
1129   (:args (x :scs (signed-reg)
1130             :load-if (not (and (sc-is x signed-stack)
1131                                (sc-is y signed-reg))))
1132          (y :scs (signed-reg signed-stack)))
1133   (:arg-types signed-num signed-num)
1134   (:note "inline (signed-byte 64) comparison"))
1135
1136 (define-vop (fast-conditional-c/signed fast-conditional/signed)
1137   (:args (x :scs (signed-reg)
1138             :load-if (or (not (typep y '(signed-byte 32)))
1139                          (not (sc-is x signed-reg signed-stack)))))
1140   (:arg-types signed-num (:constant (signed-byte 64)))
1141   (:info y))
1142
1143 (define-vop (fast-conditional/unsigned fast-conditional)
1144   (:args (x :scs (unsigned-reg)
1145             :load-if (not (and (sc-is x unsigned-stack)
1146                                (sc-is y unsigned-reg))))
1147          (y :scs (unsigned-reg unsigned-stack)))
1148   (:arg-types unsigned-num unsigned-num)
1149   (:note "inline (unsigned-byte 64) comparison"))
1150
1151 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
1152   (:args (x :scs (unsigned-reg)
1153             :load-if (or (not (typep y '(unsigned-byte 31)))
1154                          (not (sc-is x unsigned-reg unsigned-stack)))))
1155   (:arg-types unsigned-num (:constant (unsigned-byte 64)))
1156   (:info y))
1157
1158 ;; Stolen liberally from the x86 32-bit implementation.
1159 (macrolet ((define-logtest-vops ()
1160              `(progn
1161                ,@(loop for suffix in '(/fixnum -c/fixnum
1162                                        /signed -c/signed
1163                                        /unsigned -c/unsigned)
1164                        for cost in '(4 3 6 5 6 5)
1165                        collect
1166                        `(define-vop (,(symbolicate "FAST-LOGTEST" suffix)
1167                                      ,(symbolicate "FAST-CONDITIONAL" suffix))
1168                          (:translate logtest)
1169                          (:conditional :ne)
1170                          (:generator ,cost
1171                           (emit-optimized-test-inst x
1172                            ,(if (eq suffix '-c/fixnum)
1173                                 ;; See whether (fixnumize y) fits in signed 32
1174                                 ;; to avoid chip's sign-extension of imm32 val.
1175                                 `(if (typep y 'short-tagged-num)
1176                                      (fixnumize y)
1177                                      (register-inline-constant :qword (fixnumize y)))
1178                                 `(cond ((typep y '(signed-byte 32)) ; same
1179                                         y)
1180                                        ((typep y '(or (unsigned-byte 64) (signed-byte 64)))
1181                                         (register-inline-constant :qword y))
1182                                        (t
1183                                         y))))))))))
1184   (define-logtest-vops))
1185
1186 (defknown %logbitp (integer unsigned-byte) boolean
1187   (movable foldable flushable always-translatable))
1188
1189 ;;; only for constant folding within the compiler
1190 (defun %logbitp (integer index)
1191   (logbitp index integer))
1192
1193 ;;; too much work to do the non-constant case (maybe?)
1194 (define-vop (fast-logbitp-c/fixnum fast-conditional-c/fixnum)
1195   (:translate %logbitp)
1196   (:conditional :c)
1197   (:arg-types tagged-num (:constant (integer 0 #.(- 63 n-fixnum-tag-bits))))
1198   (:generator 4
1199     (inst bt x (+ y n-fixnum-tag-bits))))
1200
1201 (define-vop (fast-logbitp/signed fast-conditional/signed)
1202   (:args (x :scs (signed-reg signed-stack))
1203          (y :scs (signed-reg)))
1204   (:translate %logbitp)
1205   (:conditional :c)
1206   (:generator 6
1207     (inst bt x y)))
1208
1209 (define-vop (fast-logbitp-c/signed fast-conditional-c/signed)
1210   (:translate %logbitp)
1211   (:conditional :c)
1212   (:arg-types signed-num (:constant (integer 0 63)))
1213   (:generator 5
1214     (inst bt x y)))
1215
1216 (define-vop (fast-logbitp/unsigned fast-conditional/unsigned)
1217   (:args (x :scs (unsigned-reg unsigned-stack))
1218          (y :scs (unsigned-reg)))
1219   (:translate %logbitp)
1220   (:conditional :c)
1221   (:generator 6
1222     (inst bt x y)))
1223
1224 (define-vop (fast-logbitp-c/unsigned fast-conditional-c/unsigned)
1225   (:translate %logbitp)
1226   (:conditional :c)
1227   (:arg-types unsigned-num (:constant (integer 0 63)))
1228   (:generator 5
1229     (inst bt x y)))
1230
1231 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
1232              `(progn
1233                 ,@(mapcar
1234                    (lambda (suffix cost signed)
1235                      `(define-vop (;; FIXME: These could be done more
1236                                    ;; cleanly with SYMBOLICATE.
1237                                    ,(intern (format nil "~:@(FAST-IF-~A~A~)"
1238                                                     tran suffix))
1239                                    ,(intern
1240                                      (format nil "~:@(FAST-CONDITIONAL~A~)"
1241                                              suffix)))
1242                         (:translate ,tran)
1243                         (:conditional ,(if signed cond unsigned))
1244                         (:generator ,cost
1245                                     (inst cmp x
1246                                           ,(case suffix
1247                                              (-c/fixnum
1248                                                 `(if (typep y 'short-tagged-num)
1249                                                      (fixnumize y)
1250                                                      (register-inline-constant
1251                                                       :qword (fixnumize y))))
1252                                              (-c/signed
1253                                                 `(if (typep y '(signed-byte 32))
1254                                                      y
1255                                                      (register-inline-constant
1256                                                       :qword y)))
1257                                              (-c/unsigned
1258                                                 `(if (typep y '(unsigned-byte 31))
1259                                                      y
1260                                                      (register-inline-constant
1261                                                       :qword y)))
1262                                              (t 'y))))))
1263                    '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
1264 ;                  '(/fixnum  /signed  /unsigned)
1265                    '(4 3 6 5 6 5)
1266                    '(t t t t nil nil)))))
1267
1268   (define-conditional-vop < :l :b :ge :ae)
1269   (define-conditional-vop > :g :a :le :be))
1270
1271 (define-vop (fast-if-eql/signed fast-conditional/signed)
1272   (:translate eql)
1273   (:generator 6
1274     (inst cmp x y)))
1275
1276 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
1277   (:translate eql)
1278   (:generator 5
1279     (cond ((and (sc-is x signed-reg) (zerop y))
1280            (inst test x x))  ; smaller instruction
1281           ((typep y '(signed-byte 32))
1282            (inst cmp x y))
1283           (t
1284            (inst cmp x (register-inline-constant :qword y))))))
1285
1286 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
1287   (:translate eql)
1288   (:generator 6
1289     (inst cmp x y)))
1290
1291 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
1292   (:translate eql)
1293   (:generator 5
1294     (cond ((and (sc-is x unsigned-reg) (zerop y))
1295            (inst test x x))  ; smaller instruction
1296           ((typep y '(unsigned-byte 31))
1297            (inst cmp x y))
1298           (t
1299            (inst cmp x (register-inline-constant :qword y))))))
1300
1301 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
1302 ;;; known fixnum.
1303
1304 ;;; These versions specify a fixnum restriction on their first arg. We have
1305 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
1306 ;;; the first arg and a higher cost. The reason for doing this is to prevent
1307 ;;; fixnum specific operations from being used on word integers, spuriously
1308 ;;; consing the argument.
1309
1310 (define-vop (fast-eql/fixnum fast-conditional)
1311   (:args (x :scs (any-reg)
1312             :load-if (not (and (sc-is x control-stack)
1313                                (sc-is y any-reg))))
1314          (y :scs (any-reg control-stack)))
1315   (:arg-types tagged-num tagged-num)
1316   (:note "inline fixnum comparison")
1317   (:translate eql)
1318   (:generator 4
1319     (inst cmp x y)))
1320
1321 (define-vop (generic-eql/fixnum fast-eql/fixnum)
1322   (:args (x :scs (any-reg descriptor-reg)
1323             :load-if (not (and (sc-is x control-stack)
1324                                (sc-is y any-reg))))
1325          (y :scs (any-reg control-stack)))
1326   (:arg-types * tagged-num)
1327   (:variant-cost 7))
1328
1329 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
1330   (:args (x :scs (any-reg)
1331             :load-if (or (not (typep y 'short-tagged-num))
1332                          (not (sc-is x any-reg descriptor-reg control-stack)))))
1333   (:arg-types tagged-num (:constant fixnum))
1334   (:info y)
1335   (:translate eql)
1336   (:generator 2
1337     (cond ((and (sc-is x any-reg descriptor-reg) (zerop y))
1338            (inst test x x))  ; smaller instruction
1339           ((typep y 'short-tagged-num)
1340            (inst cmp x (fixnumize y)))
1341           (t
1342            (inst cmp x (register-inline-constant :qword (fixnumize y)))))))
1343
1344 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
1345   (:args (x :scs (any-reg descriptor-reg)))
1346   (:arg-types * (:constant fixnum))
1347   (:variant-cost 6))
1348 \f
1349 ;;;; 32-bit logical operations
1350
1351 ;;; Only the lower 6 bits of the shift amount are significant.
1352 (define-vop (shift-towards-someplace)
1353   (:policy :fast-safe)
1354   (:args (num :scs (unsigned-reg) :target r)
1355          (amount :scs (signed-reg) :target ecx))
1356   (:arg-types unsigned-num tagged-num)
1357   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
1358   (:results (r :scs (unsigned-reg) :from (:argument 0)))
1359   (:result-types unsigned-num))
1360
1361 (define-vop (shift-towards-start shift-towards-someplace)
1362   (:translate shift-towards-start)
1363   (:note "SHIFT-TOWARDS-START")
1364   (:generator 1
1365     (move r num)
1366     (move ecx amount)
1367     (inst shr r :cl)))
1368
1369 (define-vop (shift-towards-end shift-towards-someplace)
1370   (:translate shift-towards-end)
1371   (:note "SHIFT-TOWARDS-END")
1372   (:generator 1
1373     (move r num)
1374     (move ecx amount)
1375     (inst shl r :cl)))
1376 \f
1377 ;;;; Modular functions
1378
1379 (defmacro define-mod-binop ((name prototype) function)
1380   `(define-vop (,name ,prototype)
1381        (:args (x :target r :scs (unsigned-reg signed-reg)
1382                  :load-if (not (and (or (sc-is x unsigned-stack)
1383                                         (sc-is x signed-stack))
1384                                     (or (sc-is y unsigned-reg)
1385                                         (sc-is y signed-reg))
1386                                     (or (sc-is r unsigned-stack)
1387                                         (sc-is r signed-stack))
1388                                     (location= x r))))
1389               (y :scs (unsigned-reg signed-reg unsigned-stack signed-stack)))
1390      (:arg-types untagged-num untagged-num)
1391      (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1392                   :load-if (not (and (or (sc-is x unsigned-stack)
1393                                          (sc-is x signed-stack))
1394                                      (or (sc-is y unsigned-reg)
1395                                          (sc-is y unsigned-reg))
1396                                      (or (sc-is r unsigned-stack)
1397                                          (sc-is r unsigned-stack))
1398                                      (location= x r)))))
1399      (:result-types unsigned-num)
1400      (:translate ,function)))
1401 (defmacro define-mod-binop-c ((name prototype) function)
1402   `(define-vop (,name ,prototype)
1403        (:args (x :target r :scs (unsigned-reg signed-reg)
1404                  :load-if (not (and (or (sc-is x unsigned-stack)
1405                                         (sc-is x signed-stack))
1406                                     (or (sc-is r unsigned-stack)
1407                                         (sc-is r signed-stack))
1408                                     (location= x r)
1409                                     (typep y '(signed-byte 32))))))
1410      (:info y)
1411      (:arg-types untagged-num (:constant (or (unsigned-byte 64) (signed-byte 64))))
1412      (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1413                   :load-if (not (and (or (sc-is x unsigned-stack)
1414                                          (sc-is x signed-stack))
1415                                      (or (sc-is r unsigned-stack)
1416                                          (sc-is r unsigned-stack))
1417                                      (location= x r)))))
1418      (:result-types unsigned-num)
1419      (:translate ,function)))
1420
1421 (macrolet ((def (name -c-p)
1422              (let ((fun64 (intern (format nil "~S-MOD64" name)))
1423                    (vopu (intern (format nil "FAST-~S/UNSIGNED=>UNSIGNED" name)))
1424                    (vopcu (intern (format nil "FAST-~S-C/UNSIGNED=>UNSIGNED" name)))
1425                    (vopf (intern (format nil "FAST-~S/FIXNUM=>FIXNUM" name)))
1426                    (vopcf (intern (format nil "FAST-~S-C/FIXNUM=>FIXNUM" name)))
1427                    (vop64u (intern (format nil "FAST-~S-MOD64/WORD=>UNSIGNED" name)))
1428                    (vop64f (intern (format nil "FAST-~S-MOD64/FIXNUM=>FIXNUM" name)))
1429                    (vop64cu (intern (format nil "FAST-~S-MOD64-C/WORD=>UNSIGNED" name)))
1430                    (vop64cf (intern (format nil "FAST-~S-MOD64-C/FIXNUM=>FIXNUM" name)))
1431                    (funfx (intern (format nil "~S-MODFX" name)))
1432                    (vopfxf (intern (format nil "FAST-~S-MODFX/FIXNUM=>FIXNUM" name)))
1433                    (vopfxcf (intern (format nil "FAST-~S-MODFX-C/FIXNUM=>FIXNUM" name))))
1434                `(progn
1435                   (define-modular-fun ,fun64 (x y) ,name :untagged nil 64)
1436                   (define-modular-fun ,funfx (x y) ,name :tagged t
1437                                       #.(- n-word-bits n-fixnum-tag-bits))
1438                   (define-mod-binop (,vop64u ,vopu) ,fun64)
1439                   (define-vop (,vop64f ,vopf) (:translate ,fun64))
1440                   (define-vop (,vopfxf ,vopf) (:translate ,funfx))
1441                   ,@(when -c-p
1442                       `((define-mod-binop-c (,vop64cu ,vopcu) ,fun64)
1443                         (define-vop (,vopfxcf ,vopcf) (:translate ,funfx))))))))
1444   (def + t)
1445   (def - t)
1446   (def * t))
1447
1448 (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
1449              fast-ash-c/unsigned=>unsigned)
1450   (:translate ash-left-mod64))
1451 (define-vop (fast-ash-left-mod64/unsigned=>unsigned
1452              fast-ash-left/unsigned=>unsigned))
1453 (deftransform ash-left-mod64 ((integer count)
1454                               ((unsigned-byte 64) (unsigned-byte 6)))
1455   (when (sb!c::constant-lvar-p count)
1456     (sb!c::give-up-ir1-transform))
1457   '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
1458
1459 (define-vop (fast-ash-left-modfx-c/fixnum=>fixnum
1460              fast-ash-c/fixnum=>fixnum)
1461   (:variant :modular)
1462   (:translate ash-left-modfx))
1463 (define-vop (fast-ash-left-modfx/fixnum=>fixnum
1464              fast-ash-left/fixnum=>fixnum))
1465 (deftransform ash-left-modfx ((integer count)
1466                               (fixnum (unsigned-byte 6)))
1467   (when (sb!c::constant-lvar-p count)
1468     (sb!c::give-up-ir1-transform))
1469   '(%primitive fast-ash-left-modfx/fixnum=>fixnum integer count))
1470
1471 (in-package "SB!C")
1472
1473 (defknown sb!vm::%lea-mod64 (integer integer (member 1 2 4 8) (signed-byte 64))
1474   (unsigned-byte 64)
1475   (foldable flushable movable))
1476 (defknown sb!vm::%lea-modfx (integer integer (member 1 2 4 8) (signed-byte 64))
1477   fixnum
1478   (foldable flushable movable))
1479
1480 (define-modular-fun-optimizer %lea ((base index scale disp) :untagged nil :width width)
1481   (when (and (<= width 64)
1482              (constant-lvar-p scale)
1483              (constant-lvar-p disp))
1484     (cut-to-width base :untagged width nil)
1485     (cut-to-width index :untagged width nil)
1486     'sb!vm::%lea-mod64))
1487 (define-modular-fun-optimizer %lea ((base index scale disp) :tagged t :width width)
1488   (when (and (<= width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
1489              (constant-lvar-p scale)
1490              (constant-lvar-p disp))
1491     (cut-to-width base :tagged width t)
1492     (cut-to-width index :tagged width t)
1493     'sb!vm::%lea-modfx))
1494
1495 #+sb-xc-host
1496 (progn
1497   (defun sb!vm::%lea-mod64 (base index scale disp)
1498     (ldb (byte 64 0) (%lea base index scale disp)))
1499   (defun sb!vm::%lea-modfx (base index scale disp)
1500     (mask-signed-field (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)
1501                        (%lea base index scale disp))))
1502 #-sb-xc-host
1503 (progn
1504   (defun sb!vm::%lea-mod64 (base index scale disp)
1505     (let ((base (logand base #xffffffffffffffff))
1506           (index (logand index #xffffffffffffffff)))
1507       ;; can't use modular version of %LEA, as we only have VOPs for
1508       ;; constant SCALE and DISP.
1509       (ldb (byte 64 0) (+ base (* index scale) disp))))
1510   (defun sb!vm::%lea-modfx (base index scale disp)
1511     (let* ((fixnum-width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
1512            (base (mask-signed-field fixnum-width base))
1513            (index (mask-signed-field fixnum-width index)))
1514       ;; can't use modular version of %LEA, as we only have VOPs for
1515       ;; constant SCALE and DISP.
1516       (mask-signed-field fixnum-width (+ base (* index scale) disp)))))
1517
1518 (in-package "SB!VM")
1519
1520 (define-vop (%lea-mod64/unsigned=>unsigned
1521              %lea/unsigned=>unsigned)
1522   (:translate %lea-mod64))
1523 (define-vop (%lea-modfx/fixnum=>fixnum
1524              %lea/fixnum=>fixnum)
1525   (:translate %lea-modfx))
1526
1527 ;;; logical operations
1528 (define-modular-fun lognot-mod64 (x) lognot :untagged nil 64)
1529 (define-vop (lognot-mod64/unsigned=>unsigned)
1530   (:translate lognot-mod64)
1531   (:args (x :scs (unsigned-reg unsigned-stack) :target r
1532             :load-if (not (and (sc-is x unsigned-stack)
1533                                (sc-is r unsigned-stack)
1534                                (location= x r)))))
1535   (:arg-types unsigned-num)
1536   (:results (r :scs (unsigned-reg)
1537                :load-if (not (and (sc-is x unsigned-stack)
1538                                   (sc-is r unsigned-stack)
1539                                   (location= x r)))))
1540   (:result-types unsigned-num)
1541   (:policy :fast-safe)
1542   (:generator 1
1543     (move r x)
1544     (inst not r)))
1545
1546 (define-source-transform logeqv (&rest args)
1547   (if (oddp (length args))
1548       `(logxor ,@args)
1549       `(lognot (logxor ,@args))))
1550 (define-source-transform logandc1 (x y)
1551   `(logand (lognot ,x) ,y))
1552 (define-source-transform logandc2 (x y)
1553   `(logand ,x (lognot ,y)))
1554 (define-source-transform logorc1 (x y)
1555   `(logior (lognot ,x) ,y))
1556 (define-source-transform logorc2 (x y)
1557   `(logior ,x (lognot ,y)))
1558 (define-source-transform lognor (x y)
1559   `(lognot (logior ,x ,y)))
1560 (define-source-transform lognand (x y)
1561   `(lognot (logand ,x ,y)))
1562 \f
1563 ;;;; bignum stuff
1564
1565 (define-vop (bignum-length get-header-data)
1566   (:translate sb!bignum:%bignum-length)
1567   (:policy :fast-safe))
1568
1569 (define-vop (bignum-set-length set-header-data)
1570   (:translate sb!bignum:%bignum-set-length)
1571   (:policy :fast-safe))
1572
1573 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
1574   (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
1575 (define-full-reffer+offset bignum--ref-with-offset * bignum-digits-offset
1576   other-pointer-lowtag (unsigned-reg) unsigned-num
1577   sb!bignum:%bignum-ref-with-offset)
1578 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
1579   (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
1580
1581 (define-vop (digit-0-or-plus)
1582   (:translate sb!bignum:%digit-0-or-plusp)
1583   (:policy :fast-safe)
1584   (:args (digit :scs (unsigned-reg)))
1585   (:arg-types unsigned-num)
1586   (:conditional :ns)
1587   (:generator 3
1588     (inst test digit digit)))
1589
1590
1591 ;;; For add and sub with carry the sc of carry argument is any-reg so
1592 ;;; that it may be passed as a fixnum or word and thus may be 0, 1, or
1593 ;;; 8. This is easy to deal with and may save a fixnum-word
1594 ;;; conversion.
1595 (define-vop (add-w/carry)
1596   (:translate sb!bignum:%add-with-carry)
1597   (:policy :fast-safe)
1598   (:args (a :scs (unsigned-reg) :target result)
1599          (b :scs (unsigned-reg unsigned-stack) :to :eval)
1600          (c :scs (any-reg) :target temp))
1601   (:arg-types unsigned-num unsigned-num positive-fixnum)
1602   (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
1603   (:results (result :scs (unsigned-reg) :from (:argument 0))
1604             (carry :scs (unsigned-reg)))
1605   (:result-types unsigned-num positive-fixnum)
1606   (:generator 4
1607     (move result a)
1608     (move temp c)
1609     (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
1610     (inst adc result b)
1611     (inst mov carry 0)
1612     (inst adc carry carry)))
1613
1614 ;;; Note: the borrow is 1 for no borrow and 0 for a borrow, the opposite
1615 ;;; of the x86-64 convention.
1616 (define-vop (sub-w/borrow)
1617   (:translate sb!bignum:%subtract-with-borrow)
1618   (:policy :fast-safe)
1619   (:args (a :scs (unsigned-reg) :to :eval :target result)
1620          (b :scs (unsigned-reg unsigned-stack) :to :result)
1621          (c :scs (any-reg control-stack)))
1622   (:arg-types unsigned-num unsigned-num positive-fixnum)
1623   (:results (result :scs (unsigned-reg) :from :eval)
1624             (borrow :scs (unsigned-reg)))
1625   (:result-types unsigned-num positive-fixnum)
1626   (:generator 5
1627     (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
1628     (move result a)
1629     (inst sbb result b)
1630     (inst mov borrow 1)
1631     (inst sbb borrow 0)))
1632
1633
1634 (define-vop (bignum-mult-and-add-3-arg)
1635   (:translate sb!bignum:%multiply-and-add)
1636   (:policy :fast-safe)
1637   (:args (x :scs (unsigned-reg) :target eax)
1638          (y :scs (unsigned-reg unsigned-stack))
1639          (carry-in :scs (unsigned-reg unsigned-stack)))
1640   (:arg-types unsigned-num unsigned-num unsigned-num)
1641   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1642                    :to (:result 1) :target lo) eax)
1643   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1644                    :to (:result 0) :target hi) edx)
1645   (:results (hi :scs (unsigned-reg))
1646             (lo :scs (unsigned-reg)))
1647   (:result-types unsigned-num unsigned-num)
1648   (:generator 20
1649     (move eax x)
1650     (inst mul eax y)
1651     (inst add eax carry-in)
1652     (inst adc edx 0)
1653     (move hi edx)
1654     (move lo eax)))
1655
1656 (define-vop (bignum-mult-and-add-4-arg)
1657   (:translate sb!bignum:%multiply-and-add)
1658   (:policy :fast-safe)
1659   (:args (x :scs (unsigned-reg) :target eax)
1660          (y :scs (unsigned-reg unsigned-stack))
1661          (prev :scs (unsigned-reg unsigned-stack))
1662          (carry-in :scs (unsigned-reg unsigned-stack)))
1663   (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1664   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1665                    :to (:result 1) :target lo) eax)
1666   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1667                    :to (:result 0) :target hi) edx)
1668   (:results (hi :scs (unsigned-reg))
1669             (lo :scs (unsigned-reg)))
1670   (:result-types unsigned-num unsigned-num)
1671   (:generator 20
1672     (move eax x)
1673     (inst mul eax y)
1674     (inst add eax prev)
1675     (inst adc edx 0)
1676     (inst add eax carry-in)
1677     (inst adc edx 0)
1678     (move hi edx)
1679     (move lo eax)))
1680
1681
1682 (define-vop (bignum-mult)
1683   (:translate sb!bignum:%multiply)
1684   (:policy :fast-safe)
1685   (:args (x :scs (unsigned-reg) :target eax)
1686          (y :scs (unsigned-reg unsigned-stack)))
1687   (:arg-types unsigned-num unsigned-num)
1688   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1689                    :to (:result 1) :target lo) eax)
1690   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1691                    :to (:result 0) :target hi) edx)
1692   (:results (hi :scs (unsigned-reg))
1693             (lo :scs (unsigned-reg)))
1694   (:result-types unsigned-num unsigned-num)
1695   (:generator 20
1696     (move eax x)
1697     (inst mul eax y)
1698     (move hi edx)
1699     (move lo eax)))
1700
1701 #!+multiply-high-vops
1702 (define-vop (mulhi)
1703   (:translate sb!kernel:%multiply-high)
1704   (:policy :fast-safe)
1705   (:args (x :scs (unsigned-reg) :target eax)
1706          (y :scs (unsigned-reg unsigned-stack)))
1707   (:arg-types unsigned-num unsigned-num)
1708   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0))
1709               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   (:result-types unsigned-num)
1714   (:generator 20
1715     (move eax x)
1716     (inst mul eax y)
1717     (move hi edx)))
1718
1719 #!+multiply-high-vops
1720 (define-vop (mulhi/fx)
1721   (:translate sb!kernel:%multiply-high)
1722   (:policy :fast-safe)
1723   (:args (x :scs (any-reg) :target eax)
1724          (y :scs (unsigned-reg unsigned-stack)))
1725   (:arg-types positive-fixnum unsigned-num)
1726   (:temporary (:sc any-reg :offset eax-offset :from (:argument 0)) eax)
1727   (:temporary (:sc any-reg :offset edx-offset :from (:argument 1)
1728                    :to (:result 0) :target hi) edx)
1729   (:results (hi :scs (any-reg)))
1730   (:result-types positive-fixnum)
1731   (:generator 15
1732     (move eax x)
1733     (inst mul eax y)
1734     (move hi edx)
1735     (inst and hi (lognot fixnum-tag-mask))))
1736
1737 (define-vop (bignum-lognot lognot-mod64/unsigned=>unsigned)
1738   (:translate sb!bignum:%lognot))
1739
1740 (define-vop (fixnum-to-digit)
1741   (:translate sb!bignum:%fixnum-to-digit)
1742   (:policy :fast-safe)
1743   (:args (fixnum :scs (any-reg control-stack) :target digit))
1744   (:arg-types tagged-num)
1745   (:results (digit :scs (unsigned-reg)
1746                    :load-if (not (and (sc-is fixnum control-stack)
1747                                       (sc-is digit unsigned-stack)
1748                                       (location= fixnum digit)))))
1749   (:result-types unsigned-num)
1750   (:generator 1
1751     (move digit fixnum)
1752     (inst sar digit n-fixnum-tag-bits)))
1753
1754 (define-vop (bignum-floor)
1755   (:translate sb!bignum:%bigfloor)
1756   (:policy :fast-safe)
1757   (:args (div-high :scs (unsigned-reg) :target edx)
1758          (div-low :scs (unsigned-reg) :target eax)
1759          (divisor :scs (unsigned-reg unsigned-stack)))
1760   (:arg-types unsigned-num unsigned-num unsigned-num)
1761   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
1762                    :to (:result 0) :target quo) eax)
1763   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
1764                    :to (:result 1) :target rem) edx)
1765   (:results (quo :scs (unsigned-reg))
1766             (rem :scs (unsigned-reg)))
1767   (:result-types unsigned-num unsigned-num)
1768   (:generator 300
1769     (move edx div-high)
1770     (move eax div-low)
1771     (inst div eax divisor)
1772     (move quo eax)
1773     (move rem edx)))
1774
1775 (define-vop (signify-digit)
1776   (:translate sb!bignum:%fixnum-digit-with-correct-sign)
1777   (:policy :fast-safe)
1778   (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
1779   (:arg-types unsigned-num)
1780   (:results (res :scs (any-reg signed-reg)
1781                  :load-if (not (and (sc-is digit unsigned-stack)
1782                                     (sc-is res control-stack signed-stack)
1783                                     (location= digit res)))))
1784   (:result-types signed-num)
1785   (:generator 1
1786     (move res digit)
1787     (when (sc-is res any-reg control-stack)
1788       (inst shl res n-fixnum-tag-bits))))
1789
1790 (define-vop (digit-ashr)
1791   (:translate sb!bignum:%ashr)
1792   (:policy :fast-safe)
1793   (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
1794          (count :scs (unsigned-reg) :target ecx))
1795   (:arg-types unsigned-num positive-fixnum)
1796   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
1797   (:results (result :scs (unsigned-reg) :from (:argument 0)
1798                     :load-if (not (and (sc-is result unsigned-stack)
1799                                        (location= digit result)))))
1800   (:result-types unsigned-num)
1801   (:generator 2
1802     (move result digit)
1803     (move ecx count)
1804     (inst sar result :cl)))
1805
1806 (define-vop (digit-ashr/c)
1807   (:translate sb!bignum:%ashr)
1808   (:policy :fast-safe)
1809   (:args (digit :scs (unsigned-reg unsigned-stack) :target result))
1810   (:arg-types unsigned-num (:constant (integer 0 63)))
1811   (:info count)
1812   (:results (result :scs (unsigned-reg) :from (:argument 0)
1813                     :load-if (not (and (sc-is result unsigned-stack)
1814                                        (location= digit result)))))
1815   (:result-types unsigned-num)
1816   (:generator 1
1817     (move result digit)
1818     (inst sar result count)))
1819
1820 (define-vop (digit-lshr digit-ashr)
1821   (:translate sb!bignum:%digit-logical-shift-right)
1822   (:generator 1
1823     (move result digit)
1824     (move ecx count)
1825     (inst shr result :cl)))
1826
1827 (define-vop (digit-ashl digit-ashr)
1828   (:translate sb!bignum:%ashl)
1829   (:generator 1
1830     (move result digit)
1831     (move ecx count)
1832     (inst shl result :cl)))
1833 \f
1834 ;;;; static functions
1835
1836 (define-static-fun two-arg-/ (x y) :translate /)
1837
1838 (define-static-fun two-arg-gcd (x y) :translate gcd)
1839 (define-static-fun two-arg-lcm (x y) :translate lcm)
1840
1841 (define-static-fun two-arg-and (x y) :translate logand)
1842 (define-static-fun two-arg-ior (x y) :translate logior)
1843 (define-static-fun two-arg-xor (x y) :translate logxor)
1844
1845
1846 (in-package "SB!C")
1847
1848 (defun *-transformer (y)
1849   (cond
1850     ((= y (ash 1 (integer-length y)))
1851      ;; there's a generic transform for y = 2^k
1852      (give-up-ir1-transform))
1853     ((member y '(3 5 9))
1854      ;; we can do these multiplications directly using LEA
1855      `(%lea x x ,(1- y) 0))
1856     (t
1857      ;; A normal 64-bit multiplication takes 4 cycles on Athlon 64/Opteron.
1858      ;; Optimizing multiplications (other than the above cases) to
1859      ;; shifts/adds/leas gives a maximum improvement of 1 cycle, but requires
1860      ;; quite a lot of hairy code.
1861      (give-up-ir1-transform))))
1862
1863 (deftransform * ((x y)
1864                  ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1865                  (unsigned-byte 64))
1866   "recode as leas, shifts and adds"
1867   (let ((y (lvar-value y)))
1868     (*-transformer y)))
1869 (deftransform sb!vm::*-mod64
1870     ((x y) ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1871      (unsigned-byte 64))
1872   "recode as leas, shifts and adds"
1873   (let ((y (lvar-value y)))
1874     (*-transformer y)))
1875
1876 (deftransform * ((x y)
1877                  (fixnum (constant-arg (unsigned-byte 64)))
1878                  fixnum)
1879   "recode as leas, shifts and adds"
1880   (let ((y (lvar-value y)))
1881     (*-transformer y)))
1882 (deftransform sb!vm::*-modfx
1883     ((x y) (fixnum (constant-arg (unsigned-byte 64)))
1884      fixnum)
1885   "recode as leas, shifts and adds"
1886   (let ((y (lvar-value y)))
1887     (*-transformer y)))