src/compiler/x86/arith.lisp

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