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