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