src/compiler/x86/arith.lisp

   1 ;;;; the VM definition 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
  14 (file-comment
  15  "$Header$")
  16 \f
  17 ;;;; unary operations
  18
  19 (define-vop (fast-safe-arith-op)
  20   (:policy :fast-safe)
  21   (:effects)
  22   (:affected))
  23
  24 (define-vop (fixnum-unop fast-safe-arith-op)
  25   (:args (x :scs (any-reg) :target res))
  26   (:results (res :scs (any-reg)))
  27   (:note "inline fixnum arithmetic")
  28   (:arg-types tagged-num)
  29   (:result-types tagged-num))
  30
  31 (define-vop (signed-unop fast-safe-arith-op)
  32   (:args (x :scs (signed-reg) :target res))
  33   (:results (res :scs (signed-reg)))
  34   (:note "inline (signed-byte 32) arithmetic")
  35   (:arg-types signed-num)
  36   (:result-types signed-num))
  37
  38 (define-vop (fast-negate/fixnum fixnum-unop)
  39   (:translate %negate)
  40   (:generator 1
  41     (move res x)
  42     (inst neg res)))
  43
  44 (define-vop (fast-negate/signed signed-unop)
  45   (:translate %negate)
  46   (:generator 2
  47     (move res x)
  48     (inst neg res)))
  49
  50 (define-vop (fast-lognot/fixnum fixnum-unop)
  51   (:translate lognot)
  52   (:generator 2
  53     (move res x)
  54     (inst xor res (fixnumize -1))))
  55
  56 (define-vop (fast-lognot/signed signed-unop)
  57   (:translate lognot)
  58   (:generator 1
  59     (move res x)
  60     (inst not res)))
  61 \f
  62 ;;;; binary fixnum operations
  63
  64 ;;; Assume that any constant operand is the second arg...
  65
  66 (define-vop (fast-fixnum-binop fast-safe-arith-op)
  67   (:args (x :target r :scs (any-reg)
  68             :load-if (not (and (sc-is x control-stack)
  69                                (sc-is y any-reg)
  70                                (sc-is r control-stack)
  71                                (location= x r))))
  72          (y :scs (any-reg control-stack)))
  73   (:arg-types tagged-num tagged-num)
  74   (:results (r :scs (any-reg) :from (:argument 0)
  75                :load-if (not (and (sc-is x control-stack)
  76                                   (sc-is y any-reg)
  77                                   (sc-is r control-stack)
  78                                   (location= x r)))))
  79   (:result-types tagged-num)
  80   (:note "inline fixnum arithmetic"))
  81
  82 (define-vop (fast-unsigned-binop fast-safe-arith-op)
  83   (:args (x :target r :scs (unsigned-reg)
  84             :load-if (not (and (sc-is x unsigned-stack)
  85                                (sc-is y unsigned-reg)
  86                                (sc-is r unsigned-stack)
  87                                (location= x r))))
  88          (y :scs (unsigned-reg unsigned-stack)))
  89   (:arg-types unsigned-num unsigned-num)
  90   (:results (r :scs (unsigned-reg) :from (:argument 0)
  91             :load-if (not (and (sc-is x unsigned-stack)
  92                                (sc-is y unsigned-reg)
  93                                (sc-is r unsigned-stack)
  94                                (location= x r)))))
  95   (:result-types unsigned-num)
  96   (:note "inline (unsigned-byte 32) arithmetic"))
  97
  98 (define-vop (fast-signed-binop fast-safe-arith-op)
  99   (:args (x :target r :scs (signed-reg)
 100             :load-if (not (and (sc-is x signed-stack)
 101                                (sc-is y signed-reg)
 102                                (sc-is r signed-stack)
 103                                (location= x r))))
 104          (y :scs (signed-reg signed-stack)))
 105   (:arg-types signed-num signed-num)
 106   (:results (r :scs (signed-reg) :from (:argument 0)
 107             :load-if (not (and (sc-is x signed-stack)
 108                                (sc-is y signed-reg)
 109                                (sc-is r signed-stack)
 110                                (location= x r)))))
 111   (:result-types signed-num)
 112   (:note "inline (signed-byte 32) arithmetic"))
 113
 114 (define-vop (fast-fixnum-binop-c fast-safe-arith-op)
 115   (:args (x :target r :scs (any-reg control-stack)))
 116   (:info y)
 117   (:arg-types tagged-num (:constant (signed-byte 30)))
 118   (:results (r :scs (any-reg)
 119                :load-if (not (location= x r))))
 120   (:result-types tagged-num)
 121   (:note "inline fixnum arithmetic"))
 122
 123 (define-vop (fast-unsigned-binop-c fast-safe-arith-op)
 124   (:args (x :target r :scs (unsigned-reg unsigned-stack)))
 125   (:info y)
 126   (:arg-types unsigned-num (:constant (unsigned-byte 32)))
 127   (:results (r :scs (unsigned-reg)
 128                :load-if (not (location= x r))))
 129   (:result-types unsigned-num)
 130   (:note "inline (unsigned-byte 32) arithmetic"))
 131
 132 (define-vop (fast-signed-binop-c fast-safe-arith-op)
 133   (:args (x :target r :scs (signed-reg signed-stack)))
 134   (:info y)
 135   (:arg-types signed-num (:constant (signed-byte 32)))
 136   (:results (r :scs (signed-reg)
 137                :load-if (not (location= x r))))
 138   (:result-types signed-num)
 139   (:note "inline (signed-byte 32) arithmetic"))
 140
 141 (macrolet ((define-binop (translate untagged-penalty op)
 142              `(progn
 143                 (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
 144                              fast-fixnum-binop)
 145                   (:translate ,translate)
 146                   (:generator 2
 147                               (move r x)
 148                               (inst ,op r y)))
 149                 (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
 150                              fast-fixnum-binop-c)
 151                   (:translate ,translate)
 152                   (:generator 1
 153                   (move r x)
 154                   (inst ,op r (fixnumize y))))
 155                 (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
 156                              fast-signed-binop)
 157                   (:translate ,translate)
 158                   (:generator ,(1+ untagged-penalty)
 159                   (move r x)
 160                   (inst ,op r y)))
 161                 (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
 162                              fast-signed-binop-c)
 163                   (:translate ,translate)
 164                   (:generator ,untagged-penalty
 165                   (move r x)
 166                   (inst ,op r y)))
 167                 (define-vop (,(symbolicate "FAST-"
 168                                            translate
 169                                            "/UNSIGNED=>UNSIGNED")
 170                 fast-unsigned-binop)
 171                   (:translate ,translate)
 172                   (:generator ,(1+ untagged-penalty)
 173                   (move r x)
 174                   (inst ,op r y)))
 175                 (define-vop (,(symbolicate 'fast-
 176                                            translate
 177                                            '-c/unsigned=>unsigned)
 178                              fast-unsigned-binop-c)
 179                   (:translate ,translate)
 180                   (:generator ,untagged-penalty
 181                   (move r x)
 182                   (inst ,op r y))))))
 183
 184   ;;(define-binop + 4 add)
 185   (define-binop - 4 sub)
 186   (define-binop logand 2 and)
 187   (define-binop logior 2 or)
 188   (define-binop logxor 2 xor))
 189
 190
 191 ;;; Special handling of add on the x86; can use lea to avoid a
 192 ;;; register load, otherwise it uses add.
 193 (define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op)
 194   (:translate +)
 195   (:args (x :scs (any-reg) :target r
 196             :load-if (not (and (sc-is x control-stack)
 197                                (sc-is y any-reg)
 198                                (sc-is r control-stack)
 199                                (location= x r))))
 200          (y :scs (any-reg control-stack)))
 201   (:arg-types tagged-num tagged-num)
 202   (:results (r :scs (any-reg) :from (:argument 0)
 203                :load-if (not (and (sc-is x control-stack)
 204                                   (sc-is y any-reg)
 205                                   (sc-is r control-stack)
 206                                   (location= x r)))))
 207   (:result-types tagged-num)
 208   (:note "inline fixnum arithmetic")
 209   (:generator 2
 210     (cond ((and (sc-is x any-reg) (sc-is y any-reg) (sc-is r any-reg)
 211                 (not (location= x r)))
 212            (inst lea r (make-ea :dword :base x :index y :scale 1)))
 213           (t
 214            (move r x)
 215            (inst add r y)))))
 216
 217 (define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op)
 218   (:translate +)
 219   (:args (x :target r :scs (any-reg control-stack)))
 220   (:info y)
 221   (:arg-types tagged-num (:constant (signed-byte 30)))
 222   (:results (r :scs (any-reg)
 223                :load-if (not (location= x r))))
 224   (:result-types tagged-num)
 225   (:note "inline fixnum arithmetic")
 226   (:generator 1
 227     (cond ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r)))
 228            (inst lea r (make-ea :dword :base x :disp (fixnumize y))))
 229           (t
 230            (move r x)
 231            (inst add r (fixnumize y))))))
 232
 233 (define-vop (fast-+/signed=>signed fast-safe-arith-op)
 234   (:translate +)
 235   (:args (x :scs (signed-reg) :target r
 236             :load-if (not (and (sc-is x signed-stack)
 237                                (sc-is y signed-reg)
 238                                (sc-is r signed-stack)
 239                                (location= x r))))
 240          (y :scs (signed-reg signed-stack)))
 241   (:arg-types signed-num signed-num)
 242   (:results (r :scs (signed-reg) :from (:argument 0)
 243                :load-if (not (and (sc-is x signed-stack)
 244                                   (sc-is y signed-reg)
 245                                   (location= x r)))))
 246   (:result-types signed-num)
 247   (:note "inline (signed-byte 32) arithmetic")
 248   (:generator 5
 249     (cond ((and (sc-is x signed-reg) (sc-is y signed-reg) (sc-is r signed-reg)
 250                 (not (location= x r)))
 251            (inst lea r (make-ea :dword :base x :index y :scale 1)))
 252           (t
 253            (move r x)
 254            (inst add r y)))))
 255
 256 (define-vop (fast-+-c/signed=>signed fast-safe-arith-op)
 257   (:translate +)
 258   (:args (x :target r :scs (signed-reg signed-stack)))
 259   (:info y)
 260   (:arg-types signed-num (:constant (signed-byte 32)))
 261   (:results (r :scs (signed-reg)
 262                :load-if (not (location= x r))))
 263   (:result-types signed-num)
 264   (:note "inline (signed-byte 32) arithmetic")
 265   (:generator 4
 266     (cond ((and (sc-is x signed-reg) (sc-is r signed-reg)
 267                 (not (location= x r)))
 268            (inst lea r (make-ea :dword :base x :disp y)))
 269           (t
 270            (move r x)
 271            (if (= y 1)
 272                (inst inc r)
 273              (inst add r y))))))
 274
 275 (define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op)
 276   (:translate +)
 277   (:args (x :scs (unsigned-reg) :target r
 278             :load-if (not (and (sc-is x unsigned-stack)
 279                                (sc-is y unsigned-reg)
 280                                (sc-is r unsigned-stack)
 281                                (location= x r))))
 282          (y :scs (unsigned-reg unsigned-stack)))
 283   (:arg-types unsigned-num unsigned-num)
 284   (:results (r :scs (unsigned-reg) :from (:argument 0)
 285                :load-if (not (and (sc-is x unsigned-stack)
 286                                   (sc-is y unsigned-reg)
 287                                   (sc-is r unsigned-stack)
 288                                   (location= x r)))))
 289   (:result-types unsigned-num)
 290   (:note "inline (unsigned-byte 32) arithmetic")
 291   (:generator 5
 292     (cond ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg)
 293                 (sc-is r unsigned-reg) (not (location= x r)))
 294            (inst lea r (make-ea :dword :base x :index y :scale 1)))
 295           (t
 296            (move r x)
 297            (inst add r y)))))
 298
 299 (define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op)
 300   (:translate +)
 301   (:args (x :target r :scs (unsigned-reg unsigned-stack)))
 302   (:info y)
 303   (:arg-types unsigned-num (:constant (unsigned-byte 32)))
 304   (:results (r :scs (unsigned-reg)
 305                :load-if (not (location= x r))))
 306   (:result-types unsigned-num)
 307   (:note "inline (unsigned-byte 32) arithmetic")
 308   (:generator 4
 309     (cond ((and (sc-is x unsigned-reg) (sc-is r unsigned-reg)
 310                 (not (location= x r)))
 311            (inst lea r (make-ea :dword :base x :disp y)))
 312           (t
 313            (move r x)
 314            (if (= y 1)
 315                (inst inc r)
 316              (inst add r y))))))
 317 \f
 318 ;;;; multiplication and division
 319
 320 (define-vop (fast-*/fixnum=>fixnum fast-safe-arith-op)
 321   (:translate *)
 322   ;; We need different loading characteristics.
 323   (:args (x :scs (any-reg) :target r)
 324          (y :scs (any-reg control-stack)))
 325   (:arg-types tagged-num tagged-num)
 326   (:results (r :scs (any-reg) :from (:argument 0)))
 327   (:result-types tagged-num)
 328   (:note "inline fixnum arithmetic")
 329   (:generator 4
 330     (move r x)
 331     (inst sar r 2)
 332     (inst imul r y)))
 333
 334 (define-vop (fast-*-c/fixnum=>fixnum fast-safe-arith-op)
 335   (:translate *)
 336   ;; We need different loading characteristics.
 337   (:args (x :scs (any-reg control-stack)))
 338   (:info y)
 339   (:arg-types tagged-num (:constant (signed-byte 30)))
 340   (:results (r :scs (any-reg)))
 341   (:result-types tagged-num)
 342   (:note "inline fixnum arithmetic")
 343   (:generator 3
 344     (inst imul r x y)))
 345
 346 (define-vop (fast-*/signed=>signed fast-safe-arith-op)
 347   (:translate *)
 348   ;; We need different loading characteristics.
 349   (:args (x :scs (signed-reg) :target r)
 350          (y :scs (signed-reg signed-stack)))
 351   (:arg-types signed-num signed-num)
 352   (:results (r :scs (signed-reg) :from (:argument 0)))
 353   (:result-types signed-num)
 354   (:note "inline (signed-byte 32) arithmetic")
 355   (:generator 5
 356     (move r x)
 357     (inst imul r y)))
 358
 359 (define-vop (fast-*-c/signed=>signed fast-safe-arith-op)
 360   (:translate *)
 361   ;; We need different loading characteristics.
 362   (:args (x :scs (signed-reg signed-stack)))
 363   (:info y)
 364   (:arg-types signed-num (:constant (signed-byte 32)))
 365   (:results (r :scs (signed-reg)))
 366   (:result-types signed-num)
 367   (:note "inline (signed-byte 32) arithmetic")
 368   (:generator 4
 369     (inst imul r x y)))
 370
 371 (define-vop (fast-*/unsigned=>unsigned fast-safe-arith-op)
 372   (:translate *)
 373   (:args (x :scs (unsigned-reg) :target eax)
 374          (y :scs (unsigned-reg unsigned-stack)))
 375   (:arg-types unsigned-num unsigned-num)
 376   (:temporary (:sc unsigned-reg :offset eax-offset :target result
 377                    :from (:argument 0) :to :result) eax)
 378   (:temporary (:sc unsigned-reg :offset edx-offset
 379                    :from :eval :to :result) edx)
 380   (:ignore edx)
 381   (:results (result :scs (unsigned-reg)))
 382   (:result-types unsigned-num)
 383   (:note "inline (unsigned-byte 32) arithmetic")
 384   (:vop-var vop)
 385   (:save-p :compute-only)
 386   (:generator 6
 387     (move eax x)
 388     (inst mul eax y)
 389     (move result eax)))
 390
 391
 392 (define-vop (fast-truncate/fixnum=>fixnum fast-safe-arith-op)
 393   (:translate truncate)
 394   (:args (x :scs (any-reg) :target eax)
 395          (y :scs (any-reg control-stack)))
 396   (:arg-types tagged-num tagged-num)
 397   (:temporary (:sc signed-reg :offset eax-offset :target quo
 398                    :from (:argument 0) :to (:result 0)) eax)
 399   (:temporary (:sc unsigned-reg :offset edx-offset :target rem
 400                    :from (:argument 0) :to (:result 1)) edx)
 401   (:results (quo :scs (any-reg))
 402             (rem :scs (any-reg)))
 403   (:result-types tagged-num tagged-num)
 404   (:note "inline fixnum arithmetic")
 405   (:vop-var vop)
 406   (:save-p :compute-only)
 407   (:generator 31
 408     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 409       (if (sc-is y any-reg)
 410           (inst test y y)  ; smaller instruction
 411           (inst cmp y 0))
 412       (inst jmp :eq zero))
 413     (move eax x)
 414     (inst cdq)
 415     (inst idiv eax y)
 416     (if (location= quo eax)
 417         (inst shl eax 2)
 418         (inst lea quo (make-ea :dword :index eax :scale 4)))
 419     (move rem edx)))
 420
 421 (define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
 422   (:translate truncate)
 423   (:args (x :scs (any-reg) :target eax))
 424   (:info y)
 425   (:arg-types tagged-num (:constant (signed-byte 30)))
 426   (:temporary (:sc signed-reg :offset eax-offset :target quo
 427                    :from :argument :to (:result 0)) eax)
 428   (:temporary (:sc any-reg :offset edx-offset :target rem
 429                    :from :eval :to (:result 1)) edx)
 430   (:temporary (:sc any-reg :from :eval :to :result) y-arg)
 431   (:results (quo :scs (any-reg))
 432             (rem :scs (any-reg)))
 433   (:result-types tagged-num tagged-num)
 434   (:note "inline fixnum arithmetic")
 435   (:vop-var vop)
 436   (:save-p :compute-only)
 437   (:generator 30
 438     (move eax x)
 439     (inst cdq)
 440     (inst mov y-arg (fixnumize y))
 441     (inst idiv eax y-arg)
 442     (if (location= quo eax)
 443         (inst shl eax 2)
 444         (inst lea quo (make-ea :dword :index eax :scale 4)))
 445     (move rem edx)))
 446
 447 (define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
 448   (:translate truncate)
 449   (:args (x :scs (unsigned-reg) :target eax)
 450          (y :scs (unsigned-reg signed-stack)))
 451   (:arg-types unsigned-num unsigned-num)
 452   (:temporary (:sc unsigned-reg :offset eax-offset :target quo
 453                    :from (:argument 0) :to (:result 0)) eax)
 454   (:temporary (:sc unsigned-reg :offset edx-offset :target rem
 455                    :from (:argument 0) :to (:result 1)) edx)
 456   (:results (quo :scs (unsigned-reg))
 457             (rem :scs (unsigned-reg)))
 458   (:result-types unsigned-num unsigned-num)
 459   (:note "inline (unsigned-byte 32) arithmetic")
 460   (:vop-var vop)
 461   (:save-p :compute-only)
 462   (:generator 33
 463     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 464       (if (sc-is y unsigned-reg)
 465           (inst test y y)  ; smaller instruction
 466           (inst cmp y 0))
 467       (inst jmp :eq zero))
 468     (move eax x)
 469     (inst xor edx edx)
 470     (inst div eax y)
 471     (move quo eax)
 472     (move rem edx)))
 473
 474 (define-vop (fast-truncate-c/unsigned=>unsigned fast-safe-arith-op)
 475   (:translate truncate)
 476   (:args (x :scs (unsigned-reg) :target eax))
 477   (:info y)
 478   (:arg-types unsigned-num (:constant (unsigned-byte 32)))
 479   (:temporary (:sc unsigned-reg :offset eax-offset :target quo
 480                    :from :argument :to (:result 0)) eax)
 481   (:temporary (:sc unsigned-reg :offset edx-offset :target rem
 482                    :from :eval :to (:result 1)) edx)
 483   (:temporary (:sc unsigned-reg :from :eval :to :result) y-arg)
 484   (:results (quo :scs (unsigned-reg))
 485             (rem :scs (unsigned-reg)))
 486   (:result-types unsigned-num unsigned-num)
 487   (:note "inline (unsigned-byte 32) arithmetic")
 488   (:vop-var vop)
 489   (:save-p :compute-only)
 490   (:generator 32
 491     (move eax x)
 492     (inst xor edx edx)
 493     (inst mov y-arg y)
 494     (inst div eax y-arg)
 495     (move quo eax)
 496     (move rem edx)))
 497
 498 (define-vop (fast-truncate/signed=>signed fast-safe-arith-op)
 499   (:translate truncate)
 500   (:args (x :scs (signed-reg) :target eax)
 501          (y :scs (signed-reg signed-stack)))
 502   (:arg-types signed-num signed-num)
 503   (:temporary (:sc signed-reg :offset eax-offset :target quo
 504                    :from (:argument 0) :to (:result 0)) eax)
 505   (:temporary (:sc signed-reg :offset edx-offset :target rem
 506                    :from (:argument 0) :to (:result 1)) edx)
 507   (:results (quo :scs (signed-reg))
 508             (rem :scs (signed-reg)))
 509   (:result-types signed-num signed-num)
 510   (:note "inline (signed-byte 32) arithmetic")
 511   (:vop-var vop)
 512   (:save-p :compute-only)
 513   (:generator 33
 514     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 515       (if (sc-is y signed-reg)
 516           (inst test y y)  ; smaller instruction
 517           (inst cmp y 0))
 518       (inst jmp :eq zero))
 519     (move eax x)
 520     (inst cdq)
 521     (inst idiv eax y)
 522     (move quo eax)
 523     (move rem edx)))
 524
 525 (define-vop (fast-truncate-c/signed=>signed fast-safe-arith-op)
 526   (:translate truncate)
 527   (:args (x :scs (signed-reg) :target eax))
 528   (:info y)
 529   (:arg-types signed-num (:constant (signed-byte 32)))
 530   (:temporary (:sc signed-reg :offset eax-offset :target quo
 531                    :from :argument :to (:result 0)) eax)
 532   (:temporary (:sc signed-reg :offset edx-offset :target rem
 533                    :from :eval :to (:result 1)) edx)
 534   (:temporary (:sc signed-reg :from :eval :to :result) y-arg)
 535   (:results (quo :scs (signed-reg))
 536             (rem :scs (signed-reg)))
 537   (:result-types signed-num signed-num)
 538   (:note "inline (signed-byte 32) arithmetic")
 539   (:vop-var vop)
 540   (:save-p :compute-only)
 541   (:generator 32
 542     (move eax x)
 543     (inst cdq)
 544     (inst mov y-arg y)
 545     (inst idiv eax y-arg)
 546     (move quo eax)
 547     (move rem edx)))
 548
 549
 550 \f
 551 ;;;; Shifting
 552 (define-vop (fast-ash-c/fixnum=>fixnum)
 553   (:translate ash)
 554   (:policy :fast-safe)
 555   (:args (number :scs (any-reg) :target result
 556                  :load-if (not (and (sc-is number any-reg control-stack)
 557                                     (sc-is result any-reg control-stack)
 558                                     (location= number result)))))
 559   (:info amount)
 560   (:arg-types tagged-num (:constant integer))
 561   (:results (result :scs (any-reg)
 562                     :load-if (not (and (sc-is number control-stack)
 563                                        (sc-is result control-stack)
 564                                        (location= number result)))))
 565   (:result-types tagged-num)
 566   (:note "inline ASH")
 567   (:generator 2
 568     (cond ((and (= amount 1) (not (location= number result)))
 569            (inst lea result (make-ea :dword :index number :scale 2)))
 570           ((and (= amount 2) (not (location= number result)))
 571            (inst lea result (make-ea :dword :index number :scale 4)))
 572           ((and (= amount 3) (not (location= number result)))
 573            (inst lea result (make-ea :dword :index number :scale 8)))
 574           (t
 575            (move result number)
 576            (cond ((plusp amount)
 577                   ;; We don't have to worry about overflow because of the
 578                   ;; result type restriction.
 579                   (inst shl result amount))
 580                  (t
 581                   ;; If the amount is greater than 31, only shift by 31. We
 582                   ;; have to do this because the shift instructions only look
 583                   ;; at the low five bits of the result.
 584                   (inst sar result (min 31 (- amount)))
 585                   ;; Fixnum correction.
 586                   (inst and result #xfffffffc)))))))
 587
 588 (define-vop (fast-ash-left/fixnum=>fixnum)
 589   (:translate ash)
 590   (:args (number :scs (any-reg) :target result
 591                  :load-if (not (and (sc-is number control-stack)
 592                                     (sc-is result control-stack)
 593                                     (location= number result))))
 594          (amount :scs (unsigned-reg) :target ecx))
 595   (:arg-types tagged-num positive-fixnum)
 596   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
 597   (:results (result :scs (any-reg) :from (:argument 0)
 598                     :load-if (not (and (sc-is number control-stack)
 599                                        (sc-is result control-stack)
 600                                        (location= number result)))))
 601   (:result-types tagged-num)
 602   (:policy :fast-safe)
 603   (:note "inline ASH")
 604   (:generator 3
 605     (move result number)
 606     (move ecx amount)
 607     ;; The result-type ensures us that this shift will not overflow.
 608     (inst shl result :cl)))
 609
 610 (define-vop (fast-ash-c)
 611   (:translate ash)
 612   (:policy :fast-safe)
 613   (:args (number :scs (signed-reg unsigned-reg) :target result
 614                  :load-if (not (and (sc-is number signed-stack unsigned-stack)
 615                                     (sc-is result signed-stack unsigned-stack)
 616                                     (location= number result)))))
 617   (:info amount)
 618   (:arg-types (:or signed-num unsigned-num) (:constant integer))
 619   (:results (result :scs (signed-reg unsigned-reg)
 620                     :load-if (not
 621                               (and (sc-is number signed-stack unsigned-stack)
 622                                    (sc-is result signed-stack unsigned-stack)
 623                                    (location= number result)))))
 624   (:result-types (:or signed-num unsigned-num))
 625   (:note "inline ASH")
 626   (:generator 3
 627     (cond ((and (= amount 1) (not (location= number result)))
 628            (inst lea result (make-ea :dword :index number :scale 2)))
 629           ((and (= amount 2) (not (location= number result)))
 630            (inst lea result (make-ea :dword :index number :scale 4)))
 631           ((and (= amount 3) (not (location= number result)))
 632            (inst lea result (make-ea :dword :index number :scale 8)))
 633           (t
 634            (move result number)
 635            (cond ((plusp amount)
 636                   ;; We don't have to worry about overflow because of the
 637                   ;; result type restriction.
 638                   (inst shl result amount))
 639                  ((sc-is number signed-reg signed-stack)
 640                   ;; If the amount is greater than 31, only shift by 31. We
 641                   ;; have to do this because the shift instructions only look
 642                   ;; at the low five bits of the result.
 643                   (inst sar result (min 31 (- amount))))
 644                  (t
 645                   (inst shr result (min 31 (- amount)))))))))
 646
 647 (define-vop (fast-ash-left)
 648   (:translate ash)
 649   (:args (number :scs (signed-reg unsigned-reg) :target result
 650                  :load-if (not (and (sc-is number signed-stack unsigned-stack)
 651                                     (sc-is result signed-stack unsigned-stack)
 652                                     (location= number result))))
 653          (amount :scs (unsigned-reg) :target ecx))
 654   (:arg-types (:or signed-num unsigned-num) positive-fixnum)
 655   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
 656   (:results (result :scs (signed-reg unsigned-reg) :from (:argument 0)
 657                     :load-if (not
 658                               (and (sc-is number signed-stack unsigned-stack)
 659                                    (sc-is result signed-stack unsigned-stack)
 660                                    (location= number result)))))
 661   (:result-types (:or signed-num unsigned-num))
 662   (:policy :fast-safe)
 663   (:note "inline ASH")
 664   (:generator 4
 665     (move result number)
 666     (move ecx amount)
 667     ;; The result-type ensures us that this shift will not overflow.
 668     (inst shl result :cl)))
 669
 670 (define-vop (fast-ash)
 671   (:translate ash)
 672   (:policy :fast-safe)
 673   (:args (number :scs (signed-reg unsigned-reg) :target result)
 674          (amount :scs (signed-reg) :target ecx))
 675   (:arg-types (:or signed-num unsigned-num) signed-num)
 676   (:results (result :scs (signed-reg unsigned-reg) :from (:argument 0)))
 677   (:result-types (:or signed-num unsigned-num))
 678   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
 679   (:note "inline ASH")
 680   (:generator 5
 681     (move result number)
 682      (move ecx amount)
 683     (inst or ecx ecx)
 684     (inst jmp :ns positive)
 685     (inst neg ecx)
 686     (inst cmp ecx 31)
 687     (inst jmp :be okay)
 688     (inst mov ecx 31)
 689     OKAY
 690     (sc-case number
 691       (signed-reg (inst sar result :cl))
 692       (unsigned-reg (inst shr result :cl)))
 693     (inst jmp done)
 694
 695     POSITIVE
 696     ;; The result-type ensures us that this shift will not overflow.
 697     (inst shl result :cl)
 698
 699     DONE))
 700 \f
 701 ;;; Note: documentation for this function is wrong - rtfm
 702 (define-vop (signed-byte-32-len)
 703   (:translate integer-length)
 704   (:note "inline (signed-byte 32) integer-length")
 705   (:policy :fast-safe)
 706   (:args (arg :scs (signed-reg) :target res))
 707   (:arg-types signed-num)
 708   (:results (res :scs (any-reg)))
 709   (:result-types positive-fixnum)
 710   (:generator 30
 711     (move res arg)
 712     (inst cmp res 0)
 713     (inst jmp :ge POS)
 714     (inst not res)
 715     POS
 716     (inst bsr res res)
 717     (inst jmp :z zero)
 718     (inst inc res)
 719     (inst shl res 2)
 720     (inst jmp done)
 721     ZERO
 722     (inst xor res res)
 723     DONE))
 724
 725 (define-vop (unsigned-byte-32-count)
 726   (:translate logcount)
 727   (:note "inline (unsigned-byte 32) logcount")
 728   (:policy :fast-safe)
 729   (:args (arg :scs (unsigned-reg)))
 730   (:arg-types unsigned-num)
 731   (:results (result :scs (unsigned-reg)))
 732   (:result-types positive-fixnum)
 733   (:temporary (:sc unsigned-reg :from (:argument 0)) temp)
 734   (:generator 30
 735     (move result arg)
 736
 737     (inst mov temp result)
 738     (inst shr temp 1)
 739     (inst and result #x55555555)
 740     (inst and temp #x55555555)
 741     (inst add result temp)
 742
 743     (inst mov temp result)
 744     (inst shr temp 2)
 745     (inst and result #x33333333)
 746     (inst and temp #x33333333)
 747     (inst add result temp)
 748
 749     (inst mov temp result)
 750     (inst shr temp 4)
 751     (inst and result #x0f0f0f0f)
 752     (inst and temp #x0f0f0f0f)
 753     (inst add result temp)
 754
 755     (inst mov temp result)
 756     (inst shr temp 8)
 757     (inst and result #x00ff00ff)
 758     (inst and temp #x00ff00ff)
 759     (inst add result temp)
 760
 761     (inst mov temp result)
 762     (inst shr temp 16)
 763     (inst and result #x0000ffff)
 764     (inst and temp #x0000ffff)
 765     (inst add result temp)))
 766
 767
 768 \f
 769 ;;;; binary conditional VOPs
 770
 771 (define-vop (fast-conditional)
 772   (:conditional)
 773   (:info target not-p)
 774   (:effects)
 775   (:affected)
 776   (:policy :fast-safe))
 777
 778 (define-vop (fast-conditional/fixnum fast-conditional)
 779   (:args (x :scs (any-reg)
 780             :load-if (not (and (sc-is x control-stack)
 781                                (sc-is y any-reg))))
 782          (y :scs (any-reg control-stack)))
 783   (:arg-types tagged-num tagged-num)
 784   (:note "inline fixnum comparison"))
 785
 786 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
 787   (:args (x :scs (any-reg control-stack)))
 788   (:arg-types tagged-num (:constant (signed-byte 30)))
 789   (:info target not-p y))
 790
 791 (define-vop (fast-conditional/signed fast-conditional)
 792   (:args (x :scs (signed-reg)
 793             :load-if (not (and (sc-is x signed-stack)
 794                                (sc-is y signed-reg))))
 795          (y :scs (signed-reg signed-stack)))
 796   (:arg-types signed-num signed-num)
 797   (:note "inline (signed-byte 32) comparison"))
 798
 799 (define-vop (fast-conditional-c/signed fast-conditional/signed)
 800   (:args (x :scs (signed-reg signed-stack)))
 801   (:arg-types signed-num (:constant (signed-byte 32)))
 802   (:info target not-p y))
 803
 804 (define-vop (fast-conditional/unsigned fast-conditional)
 805   (:args (x :scs (unsigned-reg)
 806             :load-if (not (and (sc-is x unsigned-stack)
 807                                (sc-is y unsigned-reg))))
 808          (y :scs (unsigned-reg unsigned-stack)))
 809   (:arg-types unsigned-num unsigned-num)
 810   (:note "inline (unsigned-byte 32) comparison"))
 811
 812 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
 813   (:args (x :scs (unsigned-reg unsigned-stack)))
 814   (:arg-types unsigned-num (:constant (unsigned-byte 32)))
 815   (:info target not-p y))
 816
 817
 818 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
 819              `(progn
 820                 ,@(mapcar
 821                    #'(lambda (suffix cost signed)
 822                        `(define-vop (;; FIXME: These could be done more
 823                                      ;; cleanly with SYMBOLICATE.
 824                                      ,(intern (format nil "~:@(FAST-IF-~A~A~)"
 825                                                       tran suffix))
 826                                      ,(intern
 827                                        (format nil "~:@(FAST-CONDITIONAL~A~)"
 828                                                suffix)))
 829                           (:translate ,tran)
 830                           (:generator ,cost
 831                                       (inst cmp x
 832                                             ,(if (eq suffix '-c/fixnum)
 833                                                  '(fixnumize y)
 834                                                  'y))
 835                                       (inst jmp (if not-p
 836                                                     ,(if signed
 837                                                          not-cond
 838                                                          not-unsigned)
 839                                                     ,(if signed
 840                                                          cond
 841                                                          unsigned))
 842                                             target))))
 843                    '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
 844                    '(4 3 6 5 6 5)
 845                    '(t t t t nil nil)))))
 846
 847   (define-conditional-vop < :l :b :ge :ae)
 848   (define-conditional-vop > :g :a :le :be))
 849
 850 (define-vop (fast-if-eql/signed fast-conditional/signed)
 851   (:translate eql)
 852   (:generator 6
 853     (inst cmp x y)
 854     (inst jmp (if not-p :ne :e) target)))
 855
 856 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
 857   (:translate eql)
 858   (:generator 5
 859     (cond ((and (sc-is x signed-reg) (zerop y))
 860            (inst test x x))  ; smaller instruction
 861           (t
 862            (inst cmp x y)))
 863     (inst jmp (if not-p :ne :e) target)))
 864
 865 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
 866   (:translate eql)
 867   (:generator 6
 868     (inst cmp x y)
 869     (inst jmp (if not-p :ne :e) target)))
 870
 871 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
 872   (:translate eql)
 873   (:generator 5
 874     (cond ((and (sc-is x unsigned-reg) (zerop y))
 875            (inst test x x))  ; smaller instruction
 876           (t
 877            (inst cmp x y)))
 878     (inst jmp (if not-p :ne :e) target)))
 879
 880 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
 881 ;;; known fixnum.
 882
 883 ;;; These versions specify a fixnum restriction on their first arg. We have
 884 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
 885 ;;; the first arg and a higher cost. The reason for doing this is to prevent
 886 ;;; fixnum specific operations from being used on word integers, spuriously
 887 ;;; consing the argument.
 888
 889 (define-vop (fast-eql/fixnum fast-conditional)
 890   (:args (x :scs (any-reg)
 891             :load-if (not (and (sc-is x control-stack)
 892                                (sc-is y any-reg))))
 893          (y :scs (any-reg control-stack)))
 894   (:arg-types tagged-num tagged-num)
 895   (:note "inline fixnum comparison")
 896   (:translate eql)
 897   (:generator 4
 898     (inst cmp x y)
 899     (inst jmp (if not-p :ne :e) target)))
 900 (define-vop (generic-eql/fixnum fast-eql/fixnum)
 901   (:args (x :scs (any-reg descriptor-reg)
 902             :load-if (not (and (sc-is x control-stack)
 903                                (sc-is y any-reg))))
 904          (y :scs (any-reg control-stack)))
 905   (:arg-types * tagged-num)
 906   (:variant-cost 7))
 907
 908 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
 909   (:args (x :scs (any-reg control-stack)))
 910   (:arg-types tagged-num (:constant (signed-byte 30)))
 911   (:info target not-p y)
 912   (:translate eql)
 913   (:generator 2
 914     (cond ((and (sc-is x any-reg) (zerop y))
 915            (inst test x x))  ; smaller instruction
 916           (t
 917            (inst cmp x (fixnumize y))))
 918     (inst jmp (if not-p :ne :e) target)))
 919 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
 920   (:args (x :scs (any-reg descriptor-reg control-stack)))
 921   (:arg-types * (:constant (signed-byte 30)))
 922   (:variant-cost 6))
 923 \f
 924 ;;;; 32-bit logical operations
 925
 926 (define-vop (merge-bits)
 927   (:translate merge-bits)
 928   (:args (shift :scs (signed-reg unsigned-reg) :target ecx)
 929          (prev :scs (unsigned-reg) :target result)
 930          (next :scs (unsigned-reg)))
 931   (:arg-types tagged-num unsigned-num unsigned-num)
 932   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 0)) ecx)
 933   (:results (result :scs (unsigned-reg) :from (:argument 1)))
 934   (:result-types unsigned-num)
 935   (:policy :fast-safe)
 936   (:generator 4
 937     (move ecx shift)
 938     (move result prev)
 939     (inst shrd result next :cl)))
 940
 941 (define-vop (32bit-logical)
 942   (:args (x :scs (unsigned-reg) :target r
 943             :load-if (not (and (sc-is x unsigned-stack)
 944                                (sc-is r unsigned-stack)
 945                                (location= x r))))
 946          (y :scs (unsigned-reg)
 947             :load-if (or (not (sc-is y unsigned-stack))
 948                          (and (sc-is x unsigned-stack)
 949                               (sc-is y unsigned-stack)
 950                               (location= x r)))))
 951   (:arg-types unsigned-num unsigned-num)
 952   (:results (r :scs (unsigned-reg)
 953                :from (:argument 0)
 954                :load-if (not (and (sc-is x unsigned-stack)
 955                                   (sc-is r unsigned-stack)
 956                                   (location= x r)))))
 957   (:result-types unsigned-num)
 958   (:policy :fast-safe))
 959
 960 (define-vop (32bit-logical-not)
 961   (:translate 32bit-logical-not)
 962   (:args (x :scs (unsigned-reg) :target r
 963             :load-if (not (and (sc-is x unsigned-stack)
 964                                (sc-is r unsigned-stack)
 965                                (location= x r)))))
 966   (:arg-types unsigned-num)
 967   (:results (r :scs (unsigned-reg)
 968                :load-if (not (and (sc-is x unsigned-stack)
 969                                   (sc-is r unsigned-stack)
 970                                   (location= x r)))))
 971   (:result-types unsigned-num)
 972   (:policy :fast-safe)
 973   (:generator 1
 974     (move r x)
 975     (inst not r)))
 976
 977 (define-vop (32bit-logical-and 32bit-logical)
 978   (:translate 32bit-logical-and)
 979   (:generator 1
 980     (move r x)
 981     (inst and r y)))
 982
 983 (def-source-transform 32bit-logical-nand (x y)
 984   `(32bit-logical-not (32bit-logical-and ,x ,y)))
 985
 986 (define-vop (32bit-logical-or 32bit-logical)
 987   (:translate 32bit-logical-or)
 988   (:generator 1
 989     (move r x)
 990     (inst or r y)))
 991
 992 (def-source-transform 32bit-logical-nor (x y)
 993   `(32bit-logical-not (32bit-logical-or ,x ,y)))
 994
 995 (define-vop (32bit-logical-xor 32bit-logical)
 996   (:translate 32bit-logical-xor)
 997   (:generator 1
 998     (move r x)
 999     (inst xor r y)))
1000
1001 (def-source-transform 32bit-logical-eqv (x y)
1002   `(32bit-logical-not (32bit-logical-xor ,x ,y)))
1003
1004 (def-source-transform 32bit-logical-orc1 (x y)
1005   `(32bit-logical-or (32bit-logical-not ,x) ,y))
1006
1007 (def-source-transform 32bit-logical-orc2 (x y)
1008   `(32bit-logical-or ,x (32bit-logical-not ,y)))
1009
1010 (def-source-transform 32bit-logical-andc1 (x y)
1011   `(32bit-logical-and (32bit-logical-not ,x) ,y))
1012
1013 (def-source-transform 32bit-logical-andc2 (x y)
1014   `(32bit-logical-and ,x (32bit-logical-not ,y)))
1015
1016 ;;; Only the lower 5 bits of the shift amount are significant.
1017 (define-vop (shift-towards-someplace)
1018   (:policy :fast-safe)
1019   (:args (num :scs (unsigned-reg) :target r)
1020          (amount :scs (signed-reg) :target ecx))
1021   (:arg-types unsigned-num tagged-num)
1022   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
1023   (:results (r :scs (unsigned-reg) :from (:argument 0)))
1024   (:result-types unsigned-num))
1025
1026 (define-vop (shift-towards-start shift-towards-someplace)
1027   (:translate shift-towards-start)
1028   (:note "SHIFT-TOWARDS-START")
1029   (:generator 1
1030     (move r num)
1031     (move ecx amount)
1032     (inst shr r :cl)))
1033
1034 (define-vop (shift-towards-end shift-towards-someplace)
1035   (:translate shift-towards-end)
1036   (:note "SHIFT-TOWARDS-END")
1037   (:generator 1
1038     (move r num)
1039     (move ecx amount)
1040     (inst shl r :cl)))
1041 \f
1042 ;;;; bignum stuff
1043
1044 (define-vop (bignum-length get-header-data)
1045   (:translate sb!bignum::%bignum-length)
1046   (:policy :fast-safe))
1047
1048 (define-vop (bignum-set-length set-header-data)
1049   (:translate sb!bignum::%bignum-set-length)
1050   (:policy :fast-safe))
1051
1052 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type
1053   (unsigned-reg) unsigned-num sb!bignum::%bignum-ref)
1054
1055 (define-full-setter bignum-set * bignum-digits-offset other-pointer-type
1056   (unsigned-reg) unsigned-num sb!bignum::%bignum-set)
1057
1058 (define-vop (digit-0-or-plus)
1059   (:translate sb!bignum::%digit-0-or-plusp)
1060   (:policy :fast-safe)
1061   (:args (digit :scs (unsigned-reg)))
1062   (:arg-types unsigned-num)
1063   (:conditional)
1064   (:info target not-p)
1065   (:generator 3
1066     (inst or digit digit)
1067     (inst jmp (if not-p :s :ns) target)))
1068
1069
1070 ;;; For add and sub with carry the sc of carry argument is any-reg so
1071 ;;; the it may be passed as a fixnum or word and thus may be 0, 1, or
1072 ;;; 4. This is easy to deal with and may save a fixnum-word
1073 ;;; conversion.
1074 (define-vop (add-w/carry)
1075   (:translate sb!bignum::%add-with-carry)
1076   (:policy :fast-safe)
1077   (:args (a :scs (unsigned-reg) :target result)
1078          (b :scs (unsigned-reg unsigned-stack) :to :eval)
1079          (c :scs (any-reg) :target temp))
1080   (:arg-types unsigned-num unsigned-num positive-fixnum)
1081   (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
1082   (:results (result :scs (unsigned-reg) :from (:argument 0))
1083             (carry :scs (unsigned-reg)))
1084   (:result-types unsigned-num positive-fixnum)
1085   (:generator 4
1086     (move result a)
1087     (move temp c)
1088     (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
1089     (inst adc result b)
1090     (inst mov carry 0)
1091     (inst adc carry carry)))
1092
1093 ;;; Note: the borrow is the oppostite of the x86 convention - 1 for no
1094 ;;; borrow and 0 for a borrow.
1095 (define-vop (sub-w/borrow)
1096   (:translate sb!bignum::%subtract-with-borrow)
1097   (:policy :fast-safe)
1098   (:args (a :scs (unsigned-reg) :to :eval :target result)
1099          (b :scs (unsigned-reg unsigned-stack) :to :result)
1100          (c :scs (any-reg control-stack)))
1101   (:arg-types unsigned-num unsigned-num positive-fixnum)
1102   (:results (result :scs (unsigned-reg) :from :eval)
1103             (borrow :scs (unsigned-reg)))
1104   (:result-types unsigned-num positive-fixnum)
1105   (:generator 5
1106     (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
1107     (move result a)
1108     (inst sbb result b)
1109     (inst mov borrow 0)
1110     (inst adc borrow borrow)
1111     (inst xor borrow 1)))
1112
1113
1114 (define-vop (bignum-mult-and-add-3-arg)
1115   (:translate sb!bignum::%multiply-and-add)
1116   (:policy :fast-safe)
1117   (:args (x :scs (unsigned-reg) :target eax)
1118          (y :scs (unsigned-reg unsigned-stack))
1119          (carry-in :scs (unsigned-reg unsigned-stack)))
1120   (:arg-types unsigned-num unsigned-num unsigned-num)
1121   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1122                    :to (:result 1) :target lo) eax)
1123   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1124                    :to (:result 0) :target hi) edx)
1125   (:results (hi :scs (unsigned-reg))
1126             (lo :scs (unsigned-reg)))
1127   (:result-types unsigned-num unsigned-num)
1128   (:generator 20
1129     (move eax x)
1130     (inst mul eax y)
1131     (inst add eax carry-in)
1132     (inst adc edx 0)
1133     (move hi edx)
1134     (move lo eax)))
1135
1136 (define-vop (bignum-mult-and-add-4-arg)
1137   (:translate sb!bignum::%multiply-and-add)
1138   (:policy :fast-safe)
1139   (:args (x :scs (unsigned-reg) :target eax)
1140          (y :scs (unsigned-reg unsigned-stack))
1141          (prev :scs (unsigned-reg unsigned-stack))
1142          (carry-in :scs (unsigned-reg unsigned-stack)))
1143   (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1144   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1145                    :to (:result 1) :target lo) eax)
1146   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1147                    :to (:result 0) :target hi) edx)
1148   (:results (hi :scs (unsigned-reg))
1149             (lo :scs (unsigned-reg)))
1150   (:result-types unsigned-num unsigned-num)
1151   (:generator 20
1152     (move eax x)
1153     (inst mul eax y)
1154     (inst add eax prev)
1155     (inst adc edx 0)
1156     (inst add eax carry-in)
1157     (inst adc edx 0)
1158     (move hi edx)
1159     (move lo eax)))
1160
1161
1162 (define-vop (bignum-mult)
1163   (:translate sb!bignum::%multiply)
1164   (:policy :fast-safe)
1165   (:args (x :scs (unsigned-reg) :target eax)
1166          (y :scs (unsigned-reg unsigned-stack)))
1167   (:arg-types unsigned-num unsigned-num)
1168   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1169                    :to (:result 1) :target lo) eax)
1170   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1171                    :to (:result 0) :target hi) edx)
1172   (:results (hi :scs (unsigned-reg))
1173             (lo :scs (unsigned-reg)))
1174   (:result-types unsigned-num unsigned-num)
1175   (:generator 20
1176     (move eax x)
1177     (inst mul eax y)
1178     (move hi edx)
1179     (move lo eax)))
1180
1181 (define-vop (bignum-lognot)
1182   (:translate sb!bignum::%lognot)
1183   (:policy :fast-safe)
1184   (:args (x :scs (unsigned-reg unsigned-stack) :target r))
1185   (:arg-types unsigned-num)
1186   (:results (r :scs (unsigned-reg)
1187                :load-if (not (location= x r))))
1188   (:result-types unsigned-num)
1189   (:generator 1
1190     (move r x)
1191     (inst not r)))
1192
1193 (define-vop (fixnum-to-digit)
1194   (:translate sb!bignum::%fixnum-to-digit)
1195   (:policy :fast-safe)
1196   (:args (fixnum :scs (any-reg control-stack) :target digit))
1197   (:arg-types tagged-num)
1198   (:results (digit :scs (unsigned-reg)
1199                    :load-if (not (and (sc-is fixnum control-stack)
1200                                       (sc-is digit unsigned-stack)
1201                                       (location= fixnum digit)))))
1202   (:result-types unsigned-num)
1203   (:generator 1
1204     (move digit fixnum)
1205     (inst sar digit 2)))
1206
1207 (define-vop (bignum-floor)
1208   (:translate sb!bignum::%floor)
1209   (:policy :fast-safe)
1210   (:args (div-high :scs (unsigned-reg) :target edx)
1211          (div-low :scs (unsigned-reg) :target eax)
1212          (divisor :scs (unsigned-reg unsigned-stack)))
1213   (:arg-types unsigned-num unsigned-num unsigned-num)
1214   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
1215                    :to (:result 0) :target quo) eax)
1216   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
1217                    :to (:result 1) :target rem) edx)
1218   (:results (quo :scs (unsigned-reg))
1219             (rem :scs (unsigned-reg)))
1220   (:result-types unsigned-num unsigned-num)
1221   (:generator 300
1222     (move edx div-high)
1223     (move eax div-low)
1224     (inst div eax divisor)
1225     (move quo eax)
1226     (move rem edx)))
1227
1228 (define-vop (signify-digit)
1229   (:translate sb!bignum::%fixnum-digit-with-correct-sign)
1230   (:policy :fast-safe)
1231   (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
1232   (:arg-types unsigned-num)
1233   (:results (res :scs (any-reg signed-reg)
1234                  :load-if (not (and (sc-is digit unsigned-stack)
1235                                     (sc-is res control-stack signed-stack)
1236                                     (location= digit res)))))
1237   (:result-types signed-num)
1238   (:generator 1
1239     (move res digit)
1240     (when (sc-is res any-reg control-stack)
1241       (inst shl res 2))))
1242
1243 (define-vop (digit-ashr)
1244   (:translate sb!bignum::%ashr)
1245   (:policy :fast-safe)
1246   (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
1247          (count :scs (unsigned-reg) :target ecx))
1248   (:arg-types unsigned-num positive-fixnum)
1249   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
1250   (:results (result :scs (unsigned-reg) :from (:argument 0)
1251                     :load-if (not (and (sc-is result unsigned-stack)
1252                                        (location= digit result)))))
1253   (:result-types unsigned-num)
1254   (:generator 1
1255     (move result digit)
1256     (move ecx count)
1257     (inst sar result :cl)))
1258
1259 (define-vop (digit-lshr digit-ashr)
1260   (:translate sb!bignum::%digit-logical-shift-right)
1261   (:generator 1
1262     (move result digit)
1263     (move ecx count)
1264     (inst shr result :cl)))
1265
1266 (define-vop (digit-ashl digit-ashr)
1267   (:translate sb!bignum::%ashl)
1268   (:generator 1
1269     (move result digit)
1270     (move ecx count)
1271     (inst shl result :cl)))
1272 \f
1273 ;;;; static functions
1274
1275 (define-static-function two-arg-/ (x y) :translate /)
1276
1277 (define-static-function two-arg-gcd (x y) :translate gcd)
1278 (define-static-function two-arg-lcm (x y) :translate lcm)
1279
1280 (define-static-function two-arg-and (x y) :translate logand)
1281 (define-static-function two-arg-ior (x y) :translate logior)
1282 (define-static-function two-arg-xor (x y) :translate logxor)
1283
1284 \f
1285 ;;; Support for the Mersenne Twister, MT19937, random number generator
1286 ;;; due to Matsumoto and Nishimura.
1287 ;;;
1288 ;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A
1289 ;;; 623-dimensionally equidistributed uniform pseudorandom number
1290 ;;; generator.", ACM Transactions on Modeling and Computer Simulation,
1291 ;;; 1997, to appear.
1292 ;;;
1293 ;;; State:
1294 ;;;  0-1:   Constant matrix A. [0, #x9908b0df] (not used here)
1295 ;;;  2:     Index; init. to 1.
1296 ;;;  3-626: State.
1297 (defknown random-mt19937 ((simple-array (unsigned-byte 32) (*)))
1298   (unsigned-byte 32) ())
1299 (define-vop (random-mt19937)
1300   (:policy :fast-safe)
1301   (:translate random-mt19937)
1302   (:args (state :scs (descriptor-reg) :to :result))
1303   (:arg-types simple-array-unsigned-byte-32)
1304   (:temporary (:sc unsigned-reg :from (:eval 0) :to :result) k)
1305   (:temporary (:sc unsigned-reg :offset eax-offset
1306                    :from (:eval 0) :to :result) tmp)
1307   (:results (y :scs (unsigned-reg) :from (:eval 0)))
1308   (:result-types unsigned-num)
1309   (:generator 50
1310     (inst mov k (make-ea :dword :base state
1311                          :disp (- (* (+ 2 sb!vm:vector-data-offset)
1312                                      sb!vm:word-bytes)
1313                                   sb!vm:other-pointer-type)))
1314     (inst cmp k 624)
1315     (inst jmp :ne no-update)
1316     (inst mov tmp state)        ; The state is passed in EAX.
1317     (inst call (make-fixup 'random-mt19937-update :assembly-routine))
1318     ;; Restore k, and set to 0.
1319     (inst xor k k)
1320     NO-UPDATE
1321     ;; y = ptgfsr[k++];
1322     (inst mov y (make-ea :dword :base state :index k :scale 4
1323                          :disp (- (* (+ 3 sb!vm:vector-data-offset)
1324                                      sb!vm:word-bytes)
1325                                   sb!vm:other-pointer-type)))
1326     ;; y ^= (y >> 11);
1327     (inst shr y 11)
1328     (inst xor y (make-ea :dword :base state :index k :scale 4
1329                          :disp (- (* (+ 3 sb!vm:vector-data-offset)
1330                                      sb!vm:word-bytes)
1331                                   sb!vm:other-pointer-type)))
1332     ;; y ^= (y << 7) & #x9d2c5680
1333     (inst mov tmp y)
1334     (inst inc k)
1335     (inst shl tmp 7)
1336     (inst mov (make-ea :dword :base state
1337                        :disp (- (* (+ 2 sb!vm:vector-data-offset)
1338                                    sb!vm:word-bytes)
1339                                 sb!vm:other-pointer-type))
1340           k)
1341     (inst and tmp #x9d2c5680)
1342     (inst xor y tmp)
1343     ;; y ^= (y << 15) & #xefc60000
1344     (inst mov tmp y)
1345     (inst shl tmp 15)
1346     (inst and tmp #xefc60000)
1347     (inst xor y tmp)
1348     ;; y ^= (y >> 18);
1349     (inst mov tmp y)
1350     (inst shr tmp 18)
1351     (inst xor y tmp)))