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 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
1159              `(progn
1160                 ,@(mapcar
1161                    (lambda (suffix cost signed)
1162                      `(define-vop (;; FIXME: These could be done more
1163                                    ;; cleanly with SYMBOLICATE.
1164                                    ,(intern (format nil "~:@(FAST-IF-~A~A~)"
1165                                                     tran suffix))
1166                                    ,(intern
1167                                      (format nil "~:@(FAST-CONDITIONAL~A~)"
1168                                              suffix)))
1169                         (:translate ,tran)
1170                         (:conditional ,(if signed cond unsigned))
1171                         (:generator ,cost
1172                                     (inst cmp x
1173                                           ,(case suffix
1174                                              (-c/fixnum
1175                                                 `(if (typep y 'short-tagged-num)
1176                                                      (fixnumize y)
1177                                                      (register-inline-constant
1178                                                       :qword (fixnumize y))))
1179                                              (-c/signed
1180                                                 `(if (typep y '(signed-byte 32))
1181                                                      y
1182                                                      (register-inline-constant
1183                                                       :qword y)))
1184                                              (-c/unsigned
1185                                                 `(if (typep y '(unsigned-byte 31))
1186                                                      y
1187                                                      (register-inline-constant
1188                                                       :qword y)))
1189                                              (t 'y))))))
1190                    '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
1191 ;                  '(/fixnum  /signed  /unsigned)
1192                    '(4 3 6 5 6 5)
1193                    '(t t t t nil nil)))))
1194
1195   (define-conditional-vop < :l :b :ge :ae)
1196   (define-conditional-vop > :g :a :le :be))
1197
1198 (define-vop (fast-if-eql/signed fast-conditional/signed)
1199   (:translate eql)
1200   (:generator 6
1201     (inst cmp x y)))
1202
1203 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
1204   (:translate eql)
1205   (:generator 5
1206     (cond ((and (sc-is x signed-reg) (zerop y))
1207            (inst test x x))  ; smaller instruction
1208           ((typep y '(signed-byte 32))
1209            (inst cmp x y))
1210           (t
1211            (inst cmp x (register-inline-constant :qword y))))))
1212
1213 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
1214   (:translate eql)
1215   (:generator 6
1216     (inst cmp x y)))
1217
1218 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
1219   (:translate eql)
1220   (:generator 5
1221     (cond ((and (sc-is x unsigned-reg) (zerop y))
1222            (inst test x x))  ; smaller instruction
1223           ((typep y '(unsigned-byte 31))
1224            (inst cmp x y))
1225           (t
1226            (inst cmp x (register-inline-constant :qword y))))))
1227
1228 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
1229 ;;; known fixnum.
1230
1231 ;;; These versions specify a fixnum restriction on their first arg. We have
1232 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
1233 ;;; the first arg and a higher cost. The reason for doing this is to prevent
1234 ;;; fixnum specific operations from being used on word integers, spuriously
1235 ;;; consing the argument.
1236
1237 (define-vop (fast-eql/fixnum fast-conditional)
1238   (:args (x :scs (any-reg)
1239             :load-if (not (and (sc-is x control-stack)
1240                                (sc-is y any-reg))))
1241          (y :scs (any-reg control-stack)))
1242   (:arg-types tagged-num tagged-num)
1243   (:note "inline fixnum comparison")
1244   (:translate eql)
1245   (:generator 4
1246     (inst cmp x y)))
1247
1248 (define-vop (generic-eql/fixnum fast-eql/fixnum)
1249   (:args (x :scs (any-reg descriptor-reg)
1250             :load-if (not (and (sc-is x control-stack)
1251                                (sc-is y any-reg))))
1252          (y :scs (any-reg control-stack)))
1253   (:arg-types * tagged-num)
1254   (:variant-cost 7))
1255
1256 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
1257   (:args (x :scs (any-reg)
1258             :load-if (or (not (typep y 'short-tagged-num))
1259                          (not (sc-is x any-reg descriptor-reg control-stack)))))
1260   (:arg-types tagged-num (:constant fixnum))
1261   (:info y)
1262   (:translate eql)
1263   (:generator 2
1264     (cond ((and (sc-is x any-reg descriptor-reg) (zerop y))
1265            (inst test x x))  ; smaller instruction
1266           ((typep y 'short-tagged-num)
1267            (inst cmp x (fixnumize y)))
1268           (t
1269            (inst cmp x (register-inline-constant :qword (fixnumize y)))))))
1270
1271 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
1272   (:args (x :scs (any-reg descriptor-reg)))
1273   (:arg-types * (:constant fixnum))
1274   (:variant-cost 6))
1275 \f
1276 ;;;; 32-bit logical operations
1277
1278 ;;; Only the lower 6 bits of the shift amount are significant.
1279 (define-vop (shift-towards-someplace)
1280   (:policy :fast-safe)
1281   (:args (num :scs (unsigned-reg) :target r)
1282          (amount :scs (signed-reg) :target ecx))
1283   (:arg-types unsigned-num tagged-num)
1284   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
1285   (:results (r :scs (unsigned-reg) :from (:argument 0)))
1286   (:result-types unsigned-num))
1287
1288 (define-vop (shift-towards-start shift-towards-someplace)
1289   (:translate shift-towards-start)
1290   (:note "SHIFT-TOWARDS-START")
1291   (:generator 1
1292     (move r num)
1293     (move ecx amount)
1294     (inst shr r :cl)))
1295
1296 (define-vop (shift-towards-end shift-towards-someplace)
1297   (:translate shift-towards-end)
1298   (:note "SHIFT-TOWARDS-END")
1299   (:generator 1
1300     (move r num)
1301     (move ecx amount)
1302     (inst shl r :cl)))
1303 \f
1304 ;;;; Modular functions
1305
1306 (defmacro define-mod-binop ((name prototype) function)
1307   `(define-vop (,name ,prototype)
1308        (:args (x :target r :scs (unsigned-reg signed-reg)
1309                  :load-if (not (and (or (sc-is x unsigned-stack)
1310                                         (sc-is x signed-stack))
1311                                     (or (sc-is y unsigned-reg)
1312                                         (sc-is y signed-reg))
1313                                     (or (sc-is r unsigned-stack)
1314                                         (sc-is r signed-stack))
1315                                     (location= x r))))
1316               (y :scs (unsigned-reg signed-reg unsigned-stack signed-stack)))
1317      (:arg-types untagged-num untagged-num)
1318      (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1319                   :load-if (not (and (or (sc-is x unsigned-stack)
1320                                          (sc-is x signed-stack))
1321                                      (or (sc-is y unsigned-reg)
1322                                          (sc-is y unsigned-reg))
1323                                      (or (sc-is r unsigned-stack)
1324                                          (sc-is r unsigned-stack))
1325                                      (location= x r)))))
1326      (:result-types unsigned-num)
1327      (:translate ,function)))
1328 (defmacro define-mod-binop-c ((name prototype) function)
1329   `(define-vop (,name ,prototype)
1330        (:args (x :target r :scs (unsigned-reg signed-reg)
1331                  :load-if (not (and (or (sc-is x unsigned-stack)
1332                                         (sc-is x signed-stack))
1333                                     (or (sc-is r unsigned-stack)
1334                                         (sc-is r signed-stack))
1335                                     (location= x r)
1336                                     (typep y '(signed-byte 32))))))
1337      (:info y)
1338      (:arg-types untagged-num (:constant (or (unsigned-byte 64) (signed-byte 64))))
1339      (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1340                   :load-if (not (and (or (sc-is x unsigned-stack)
1341                                          (sc-is x signed-stack))
1342                                      (or (sc-is r unsigned-stack)
1343                                          (sc-is r unsigned-stack))
1344                                      (location= x r)))))
1345      (:result-types unsigned-num)
1346      (:translate ,function)))
1347
1348 (macrolet ((def (name -c-p)
1349              (let ((fun64 (intern (format nil "~S-MOD64" name)))
1350                    (vopu (intern (format nil "FAST-~S/UNSIGNED=>UNSIGNED" name)))
1351                    (vopcu (intern (format nil "FAST-~S-C/UNSIGNED=>UNSIGNED" name)))
1352                    (vopf (intern (format nil "FAST-~S/FIXNUM=>FIXNUM" name)))
1353                    (vopcf (intern (format nil "FAST-~S-C/FIXNUM=>FIXNUM" name)))
1354                    (vop64u (intern (format nil "FAST-~S-MOD64/WORD=>UNSIGNED" name)))
1355                    (vop64f (intern (format nil "FAST-~S-MOD64/FIXNUM=>FIXNUM" name)))
1356                    (vop64cu (intern (format nil "FAST-~S-MOD64-C/WORD=>UNSIGNED" name)))
1357                    (vop64cf (intern (format nil "FAST-~S-MOD64-C/FIXNUM=>FIXNUM" name)))
1358                    (funfx (intern (format nil "~S-MODFX" name)))
1359                    (vopfxf (intern (format nil "FAST-~S-MODFX/FIXNUM=>FIXNUM" name)))
1360                    (vopfxcf (intern (format nil "FAST-~S-MODFX-C/FIXNUM=>FIXNUM" name))))
1361                `(progn
1362                   (define-modular-fun ,fun64 (x y) ,name :untagged nil 64)
1363                   (define-modular-fun ,funfx (x y) ,name :tagged t
1364                                       #.(- n-word-bits n-fixnum-tag-bits))
1365                   (define-mod-binop (,vop64u ,vopu) ,fun64)
1366                   (define-vop (,vop64f ,vopf) (:translate ,fun64))
1367                   (define-vop (,vopfxf ,vopf) (:translate ,funfx))
1368                   ,@(when -c-p
1369                       `((define-mod-binop-c (,vop64cu ,vopcu) ,fun64)
1370                         (define-vop (,vopfxcf ,vopcf) (:translate ,funfx))))))))
1371   (def + t)
1372   (def - t)
1373   (def * t))
1374
1375 (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
1376              fast-ash-c/unsigned=>unsigned)
1377   (:translate ash-left-mod64))
1378 (define-vop (fast-ash-left-mod64/unsigned=>unsigned
1379              fast-ash-left/unsigned=>unsigned))
1380 (deftransform ash-left-mod64 ((integer count)
1381                               ((unsigned-byte 64) (unsigned-byte 6)))
1382   (when (sb!c::constant-lvar-p count)
1383     (sb!c::give-up-ir1-transform))
1384   '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
1385
1386 (define-vop (fast-ash-left-modfx-c/fixnum=>fixnum
1387              fast-ash-c/fixnum=>fixnum)
1388   (:variant :modular)
1389   (:translate ash-left-modfx))
1390 (define-vop (fast-ash-left-modfx/fixnum=>fixnum
1391              fast-ash-left/fixnum=>fixnum))
1392 (deftransform ash-left-modfx ((integer count)
1393                               (fixnum (unsigned-byte 6)))
1394   (when (sb!c::constant-lvar-p count)
1395     (sb!c::give-up-ir1-transform))
1396   '(%primitive fast-ash-left-modfx/fixnum=>fixnum integer count))
1397
1398 (in-package "SB!C")
1399
1400 (defknown sb!vm::%lea-mod64 (integer integer (member 1 2 4 8) (signed-byte 64))
1401   (unsigned-byte 64)
1402   (foldable flushable movable))
1403 (defknown sb!vm::%lea-modfx (integer integer (member 1 2 4 8) (signed-byte 64))
1404   fixnum
1405   (foldable flushable movable))
1406
1407 (define-modular-fun-optimizer %lea ((base index scale disp) :untagged nil :width width)
1408   (when (and (<= width 64)
1409              (constant-lvar-p scale)
1410              (constant-lvar-p disp))
1411     (cut-to-width base :untagged width nil)
1412     (cut-to-width index :untagged width nil)
1413     'sb!vm::%lea-mod64))
1414 (define-modular-fun-optimizer %lea ((base index scale disp) :tagged t :width width)
1415   (when (and (<= width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
1416              (constant-lvar-p scale)
1417              (constant-lvar-p disp))
1418     (cut-to-width base :tagged width t)
1419     (cut-to-width index :tagged width t)
1420     'sb!vm::%lea-modfx))
1421
1422 #+sb-xc-host
1423 (progn
1424   (defun sb!vm::%lea-mod64 (base index scale disp)
1425     (ldb (byte 64 0) (%lea base index scale disp)))
1426   (defun sb!vm::%lea-modfx (base index scale disp)
1427     (mask-signed-field (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)
1428                        (%lea base index scale disp))))
1429 #-sb-xc-host
1430 (progn
1431   (defun sb!vm::%lea-mod64 (base index scale disp)
1432     (let ((base (logand base #xffffffffffffffff))
1433           (index (logand index #xffffffffffffffff)))
1434       ;; can't use modular version of %LEA, as we only have VOPs for
1435       ;; constant SCALE and DISP.
1436       (ldb (byte 64 0) (+ base (* index scale) disp))))
1437   (defun sb!vm::%lea-modfx (base index scale disp)
1438     (let* ((fixnum-width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
1439            (base (mask-signed-field fixnum-width base))
1440            (index (mask-signed-field fixnum-width index)))
1441       ;; can't use modular version of %LEA, as we only have VOPs for
1442       ;; constant SCALE and DISP.
1443       (mask-signed-field fixnum-width (+ base (* index scale) disp)))))
1444
1445 (in-package "SB!VM")
1446
1447 (define-vop (%lea-mod64/unsigned=>unsigned
1448              %lea/unsigned=>unsigned)
1449   (:translate %lea-mod64))
1450 (define-vop (%lea-modfx/fixnum=>fixnum
1451              %lea/fixnum=>fixnum)
1452   (:translate %lea-modfx))
1453
1454 ;;; logical operations
1455 (define-modular-fun lognot-mod64 (x) lognot :untagged nil 64)
1456 (define-vop (lognot-mod64/unsigned=>unsigned)
1457   (:translate lognot-mod64)
1458   (:args (x :scs (unsigned-reg unsigned-stack) :target r
1459             :load-if (not (and (sc-is x unsigned-stack)
1460                                (sc-is r unsigned-stack)
1461                                (location= x r)))))
1462   (:arg-types unsigned-num)
1463   (:results (r :scs (unsigned-reg)
1464                :load-if (not (and (sc-is x unsigned-stack)
1465                                   (sc-is r unsigned-stack)
1466                                   (location= x r)))))
1467   (:result-types unsigned-num)
1468   (:policy :fast-safe)
1469   (:generator 1
1470     (move r x)
1471     (inst not r)))
1472
1473 (define-source-transform logeqv (&rest args)
1474   (if (oddp (length args))
1475       `(logxor ,@args)
1476       `(lognot (logxor ,@args))))
1477 (define-source-transform logandc1 (x y)
1478   `(logand (lognot ,x) ,y))
1479 (define-source-transform logandc2 (x y)
1480   `(logand ,x (lognot ,y)))
1481 (define-source-transform logorc1 (x y)
1482   `(logior (lognot ,x) ,y))
1483 (define-source-transform logorc2 (x y)
1484   `(logior ,x (lognot ,y)))
1485 (define-source-transform lognor (x y)
1486   `(lognot (logior ,x ,y)))
1487 (define-source-transform lognand (x y)
1488   `(lognot (logand ,x ,y)))
1489 \f
1490 ;;;; bignum stuff
1491
1492 (define-vop (bignum-length get-header-data)
1493   (:translate sb!bignum:%bignum-length)
1494   (:policy :fast-safe))
1495
1496 (define-vop (bignum-set-length set-header-data)
1497   (:translate sb!bignum:%bignum-set-length)
1498   (:policy :fast-safe))
1499
1500 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
1501   (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
1502 (define-full-reffer+offset bignum--ref-with-offset * bignum-digits-offset
1503   other-pointer-lowtag (unsigned-reg) unsigned-num
1504   sb!bignum:%bignum-ref-with-offset)
1505 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
1506   (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
1507
1508 (define-vop (digit-0-or-plus)
1509   (:translate sb!bignum:%digit-0-or-plusp)
1510   (:policy :fast-safe)
1511   (:args (digit :scs (unsigned-reg)))
1512   (:arg-types unsigned-num)
1513   (:conditional :ns)
1514   (:generator 3
1515     (inst test digit digit)))
1516
1517
1518 ;;; For add and sub with carry the sc of carry argument is any-reg so
1519 ;;; that it may be passed as a fixnum or word and thus may be 0, 1, or
1520 ;;; 8. This is easy to deal with and may save a fixnum-word
1521 ;;; conversion.
1522 (define-vop (add-w/carry)
1523   (:translate sb!bignum:%add-with-carry)
1524   (:policy :fast-safe)
1525   (:args (a :scs (unsigned-reg) :target result)
1526          (b :scs (unsigned-reg unsigned-stack) :to :eval)
1527          (c :scs (any-reg) :target temp))
1528   (:arg-types unsigned-num unsigned-num positive-fixnum)
1529   (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
1530   (:results (result :scs (unsigned-reg) :from (:argument 0))
1531             (carry :scs (unsigned-reg)))
1532   (:result-types unsigned-num positive-fixnum)
1533   (:generator 4
1534     (move result a)
1535     (move temp c)
1536     (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
1537     (inst adc result b)
1538     (inst mov carry 0)
1539     (inst adc carry carry)))
1540
1541 ;;; Note: the borrow is 1 for no borrow and 0 for a borrow, the opposite
1542 ;;; of the x86-64 convention.
1543 (define-vop (sub-w/borrow)
1544   (:translate sb!bignum:%subtract-with-borrow)
1545   (:policy :fast-safe)
1546   (:args (a :scs (unsigned-reg) :to :eval :target result)
1547          (b :scs (unsigned-reg unsigned-stack) :to :result)
1548          (c :scs (any-reg control-stack)))
1549   (:arg-types unsigned-num unsigned-num positive-fixnum)
1550   (:results (result :scs (unsigned-reg) :from :eval)
1551             (borrow :scs (unsigned-reg)))
1552   (:result-types unsigned-num positive-fixnum)
1553   (:generator 5
1554     (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
1555     (move result a)
1556     (inst sbb result b)
1557     (inst mov borrow 1)
1558     (inst sbb borrow 0)))
1559
1560
1561 (define-vop (bignum-mult-and-add-3-arg)
1562   (:translate sb!bignum:%multiply-and-add)
1563   (:policy :fast-safe)
1564   (:args (x :scs (unsigned-reg) :target eax)
1565          (y :scs (unsigned-reg unsigned-stack))
1566          (carry-in :scs (unsigned-reg unsigned-stack)))
1567   (:arg-types unsigned-num unsigned-num unsigned-num)
1568   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1569                    :to (:result 1) :target lo) eax)
1570   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1571                    :to (:result 0) :target hi) edx)
1572   (:results (hi :scs (unsigned-reg))
1573             (lo :scs (unsigned-reg)))
1574   (:result-types unsigned-num unsigned-num)
1575   (:generator 20
1576     (move eax x)
1577     (inst mul eax y)
1578     (inst add eax carry-in)
1579     (inst adc edx 0)
1580     (move hi edx)
1581     (move lo eax)))
1582
1583 (define-vop (bignum-mult-and-add-4-arg)
1584   (:translate sb!bignum:%multiply-and-add)
1585   (:policy :fast-safe)
1586   (:args (x :scs (unsigned-reg) :target eax)
1587          (y :scs (unsigned-reg unsigned-stack))
1588          (prev :scs (unsigned-reg unsigned-stack))
1589          (carry-in :scs (unsigned-reg unsigned-stack)))
1590   (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1591   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1592                    :to (:result 1) :target lo) eax)
1593   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1594                    :to (:result 0) :target hi) edx)
1595   (:results (hi :scs (unsigned-reg))
1596             (lo :scs (unsigned-reg)))
1597   (:result-types unsigned-num unsigned-num)
1598   (:generator 20
1599     (move eax x)
1600     (inst mul eax y)
1601     (inst add eax prev)
1602     (inst adc edx 0)
1603     (inst add eax carry-in)
1604     (inst adc edx 0)
1605     (move hi edx)
1606     (move lo eax)))
1607
1608
1609 (define-vop (bignum-mult)
1610   (:translate sb!bignum:%multiply)
1611   (:policy :fast-safe)
1612   (:args (x :scs (unsigned-reg) :target eax)
1613          (y :scs (unsigned-reg unsigned-stack)))
1614   (:arg-types unsigned-num unsigned-num)
1615   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1616                    :to (:result 1) :target lo) eax)
1617   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1618                    :to (:result 0) :target hi) edx)
1619   (:results (hi :scs (unsigned-reg))
1620             (lo :scs (unsigned-reg)))
1621   (:result-types unsigned-num unsigned-num)
1622   (:generator 20
1623     (move eax x)
1624     (inst mul eax y)
1625     (move hi edx)
1626     (move lo eax)))
1627
1628 #!+multiply-high-vops
1629 (define-vop (mulhi)
1630   (:translate sb!kernel:%multiply-high)
1631   (:policy :fast-safe)
1632   (:args (x :scs (unsigned-reg) :target eax)
1633          (y :scs (unsigned-reg unsigned-stack)))
1634   (:arg-types unsigned-num unsigned-num)
1635   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0))
1636               eax)
1637   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1638                    :to (:result 0) :target hi) edx)
1639   (:results (hi :scs (unsigned-reg)))
1640   (:result-types unsigned-num)
1641   (:generator 20
1642     (move eax x)
1643     (inst mul eax y)
1644     (move hi edx)))
1645
1646 #!+multiply-high-vops
1647 (define-vop (mulhi/fx)
1648   (:translate sb!kernel:%multiply-high)
1649   (:policy :fast-safe)
1650   (:args (x :scs (any-reg) :target eax)
1651          (y :scs (unsigned-reg unsigned-stack)))
1652   (:arg-types positive-fixnum unsigned-num)
1653   (:temporary (:sc any-reg :offset eax-offset :from (:argument 0)) eax)
1654   (:temporary (:sc any-reg :offset edx-offset :from (:argument 1)
1655                    :to (:result 0) :target hi) edx)
1656   (:results (hi :scs (any-reg)))
1657   (:result-types positive-fixnum)
1658   (:generator 15
1659     (move eax x)
1660     (inst mul eax y)
1661     (move hi edx)
1662     (inst and hi (lognot fixnum-tag-mask))))
1663
1664 (define-vop (bignum-lognot lognot-mod64/unsigned=>unsigned)
1665   (:translate sb!bignum:%lognot))
1666
1667 (define-vop (fixnum-to-digit)
1668   (:translate sb!bignum:%fixnum-to-digit)
1669   (:policy :fast-safe)
1670   (:args (fixnum :scs (any-reg control-stack) :target digit))
1671   (:arg-types tagged-num)
1672   (:results (digit :scs (unsigned-reg)
1673                    :load-if (not (and (sc-is fixnum control-stack)
1674                                       (sc-is digit unsigned-stack)
1675                                       (location= fixnum digit)))))
1676   (:result-types unsigned-num)
1677   (:generator 1
1678     (move digit fixnum)
1679     (inst sar digit n-fixnum-tag-bits)))
1680
1681 (define-vop (bignum-floor)
1682   (:translate sb!bignum:%bigfloor)
1683   (:policy :fast-safe)
1684   (:args (div-high :scs (unsigned-reg) :target edx)
1685          (div-low :scs (unsigned-reg) :target eax)
1686          (divisor :scs (unsigned-reg unsigned-stack)))
1687   (:arg-types unsigned-num unsigned-num unsigned-num)
1688   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
1689                    :to (:result 0) :target quo) eax)
1690   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
1691                    :to (:result 1) :target rem) edx)
1692   (:results (quo :scs (unsigned-reg))
1693             (rem :scs (unsigned-reg)))
1694   (:result-types unsigned-num unsigned-num)
1695   (:generator 300
1696     (move edx div-high)
1697     (move eax div-low)
1698     (inst div eax divisor)
1699     (move quo eax)
1700     (move rem edx)))
1701
1702 (define-vop (signify-digit)
1703   (:translate sb!bignum:%fixnum-digit-with-correct-sign)
1704   (:policy :fast-safe)
1705   (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
1706   (:arg-types unsigned-num)
1707   (:results (res :scs (any-reg signed-reg)
1708                  :load-if (not (and (sc-is digit unsigned-stack)
1709                                     (sc-is res control-stack signed-stack)
1710                                     (location= digit res)))))
1711   (:result-types signed-num)
1712   (:generator 1
1713     (move res digit)
1714     (when (sc-is res any-reg control-stack)
1715       (inst shl res n-fixnum-tag-bits))))
1716
1717 (define-vop (digit-ashr)
1718   (:translate sb!bignum:%ashr)
1719   (:policy :fast-safe)
1720   (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
1721          (count :scs (unsigned-reg) :target ecx))
1722   (:arg-types unsigned-num positive-fixnum)
1723   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
1724   (:results (result :scs (unsigned-reg) :from (:argument 0)
1725                     :load-if (not (and (sc-is result unsigned-stack)
1726                                        (location= digit result)))))
1727   (:result-types unsigned-num)
1728   (:generator 2
1729     (move result digit)
1730     (move ecx count)
1731     (inst sar result :cl)))
1732
1733 (define-vop (digit-ashr/c)
1734   (:translate sb!bignum:%ashr)
1735   (:policy :fast-safe)
1736   (:args (digit :scs (unsigned-reg unsigned-stack) :target result))
1737   (:arg-types unsigned-num (:constant (integer 0 63)))
1738   (:info count)
1739   (:results (result :scs (unsigned-reg) :from (:argument 0)
1740                     :load-if (not (and (sc-is result unsigned-stack)
1741                                        (location= digit result)))))
1742   (:result-types unsigned-num)
1743   (:generator 1
1744     (move result digit)
1745     (inst sar result count)))
1746
1747 (define-vop (digit-lshr digit-ashr)
1748   (:translate sb!bignum:%digit-logical-shift-right)
1749   (:generator 1
1750     (move result digit)
1751     (move ecx count)
1752     (inst shr result :cl)))
1753
1754 (define-vop (digit-ashl digit-ashr)
1755   (:translate sb!bignum:%ashl)
1756   (:generator 1
1757     (move result digit)
1758     (move ecx count)
1759     (inst shl result :cl)))
1760 \f
1761 ;;;; static functions
1762
1763 (define-static-fun two-arg-/ (x y) :translate /)
1764
1765 (define-static-fun two-arg-gcd (x y) :translate gcd)
1766 (define-static-fun two-arg-lcm (x y) :translate lcm)
1767
1768 (define-static-fun two-arg-and (x y) :translate logand)
1769 (define-static-fun two-arg-ior (x y) :translate logior)
1770 (define-static-fun two-arg-xor (x y) :translate logxor)
1771
1772
1773 (in-package "SB!C")
1774
1775 (defun *-transformer (y)
1776   (cond
1777     ((= y (ash 1 (integer-length y)))
1778      ;; there's a generic transform for y = 2^k
1779      (give-up-ir1-transform))
1780     ((member y '(3 5 9))
1781      ;; we can do these multiplications directly using LEA
1782      `(%lea x x ,(1- y) 0))
1783     (t
1784      ;; A normal 64-bit multiplication takes 4 cycles on Athlon 64/Opteron.
1785      ;; Optimizing multiplications (other than the above cases) to
1786      ;; shifts/adds/leas gives a maximum improvement of 1 cycle, but requires
1787      ;; quite a lot of hairy code.
1788      (give-up-ir1-transform))))
1789
1790 (deftransform * ((x y)
1791                  ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1792                  (unsigned-byte 64))
1793   "recode as leas, shifts and adds"
1794   (let ((y (lvar-value y)))
1795     (*-transformer y)))
1796 (deftransform sb!vm::*-mod64
1797     ((x y) ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1798      (unsigned-byte 64))
1799   "recode as leas, shifts and adds"
1800   (let ((y (lvar-value y)))
1801     (*-transformer y)))
1802
1803 (deftransform * ((x y)
1804                  (fixnum (constant-arg (unsigned-byte 64)))
1805                  fixnum)
1806   "recode as leas, shifts and adds"
1807   (let ((y (lvar-value y)))
1808     (*-transformer y)))
1809 (deftransform sb!vm::*-modfx
1810     ((x y) (fixnum (constant-arg (unsigned-byte 64)))
1811      fixnum)
1812   "recode as leas, shifts and adds"
1813   (let ((y (lvar-value y)))
1814     (*-transformer y)))