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
 764
 765 \f
 766 ;;;; binary conditional VOPs
 767
 768 (define-vop (fast-conditional)
 769   (:conditional)
 770   (:info target not-p)
 771   (:effects)
 772   (:affected)
 773   (:policy :fast-safe))
 774
 775 (define-vop (fast-conditional/fixnum fast-conditional)
 776   (:args (x :scs (any-reg)
 777             :load-if (not (and (sc-is x control-stack)
 778                                (sc-is y any-reg))))
 779          (y :scs (any-reg control-stack)))
 780   (:arg-types tagged-num tagged-num)
 781   (:note "inline fixnum comparison"))
 782
 783 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
 784   (:args (x :scs (any-reg control-stack)))
 785   (:arg-types tagged-num (:constant (signed-byte 30)))
 786   (:info target not-p y))
 787
 788 (define-vop (fast-conditional/signed fast-conditional)
 789   (:args (x :scs (signed-reg)
 790             :load-if (not (and (sc-is x signed-stack)
 791                                (sc-is y signed-reg))))
 792          (y :scs (signed-reg signed-stack)))
 793   (:arg-types signed-num signed-num)
 794   (:note "inline (signed-byte 32) comparison"))
 795
 796 (define-vop (fast-conditional-c/signed fast-conditional/signed)
 797   (:args (x :scs (signed-reg signed-stack)))
 798   (:arg-types signed-num (:constant (signed-byte 32)))
 799   (:info target not-p y))
 800
 801 (define-vop (fast-conditional/unsigned fast-conditional)
 802   (:args (x :scs (unsigned-reg)
 803             :load-if (not (and (sc-is x unsigned-stack)
 804                                (sc-is y unsigned-reg))))
 805          (y :scs (unsigned-reg unsigned-stack)))
 806   (:arg-types unsigned-num unsigned-num)
 807   (:note "inline (unsigned-byte 32) comparison"))
 808
 809 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
 810   (:args (x :scs (unsigned-reg unsigned-stack)))
 811   (:arg-types unsigned-num (:constant (unsigned-byte 32)))
 812   (:info target not-p y))
 813
 814
 815 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
 816              `(progn
 817                 ,@(mapcar
 818                    #'(lambda (suffix cost signed)
 819                        `(define-vop (;; FIXME: These could be done more
 820                                      ;; cleanly with SYMBOLICATE.
 821                                      ,(intern (format nil "~:@(FAST-IF-~A~A~)"
 822                                                       tran suffix))
 823                                      ,(intern
 824                                        (format nil "~:@(FAST-CONDITIONAL~A~)"
 825                                                suffix)))
 826                           (:translate ,tran)
 827                           (:generator ,cost
 828                                       (inst cmp x
 829                                             ,(if (eq suffix '-c/fixnum)
 830                                                  '(fixnumize y)
 831                                                  'y))
 832                                       (inst jmp (if not-p
 833                                                     ,(if signed
 834                                                          not-cond
 835                                                          not-unsigned)
 836                                                     ,(if signed
 837                                                          cond
 838                                                          unsigned))
 839                                             target))))
 840                    '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
 841                    '(4 3 6 5 6 5)
 842                    '(t t t t nil nil)))))
 843
 844   (define-conditional-vop < :l :b :ge :ae)
 845   (define-conditional-vop > :g :a :le :be))
 846
 847 (define-vop (fast-if-eql/signed fast-conditional/signed)
 848   (:translate eql)
 849   (:generator 6
 850     (inst cmp x y)
 851     (inst jmp (if not-p :ne :e) target)))
 852
 853 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
 854   (:translate eql)
 855   (:generator 5
 856     (cond ((and (sc-is x signed-reg) (zerop y))
 857            (inst test x x))  ; smaller instruction
 858           (t
 859            (inst cmp x y)))
 860     (inst jmp (if not-p :ne :e) target)))
 861
 862 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
 863   (:translate eql)
 864   (:generator 6
 865     (inst cmp x y)
 866     (inst jmp (if not-p :ne :e) target)))
 867
 868 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
 869   (:translate eql)
 870   (:generator 5
 871     (cond ((and (sc-is x unsigned-reg) (zerop y))
 872            (inst test x x))  ; smaller instruction
 873           (t
 874            (inst cmp x y)))
 875     (inst jmp (if not-p :ne :e) target)))
 876
 877 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
 878 ;;; known fixnum.
 879
 880 ;;; These versions specify a fixnum restriction on their first arg. We have
 881 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
 882 ;;; the first arg and a higher cost. The reason for doing this is to prevent
 883 ;;; fixnum specific operations from being used on word integers, spuriously
 884 ;;; consing the argument.
 885
 886 (define-vop (fast-eql/fixnum fast-conditional)
 887   (:args (x :scs (any-reg)
 888             :load-if (not (and (sc-is x control-stack)
 889                                (sc-is y any-reg))))
 890          (y :scs (any-reg control-stack)))
 891   (:arg-types tagged-num tagged-num)
 892   (:note "inline fixnum comparison")
 893   (:translate eql)
 894   (:generator 4
 895     (inst cmp x y)
 896     (inst jmp (if not-p :ne :e) target)))
 897 (define-vop (generic-eql/fixnum fast-eql/fixnum)
 898   (:args (x :scs (any-reg descriptor-reg)
 899             :load-if (not (and (sc-is x control-stack)
 900                                (sc-is y any-reg))))
 901          (y :scs (any-reg control-stack)))
 902   (:arg-types * tagged-num)
 903   (:variant-cost 7))
 904
 905 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
 906   (:args (x :scs (any-reg control-stack)))
 907   (:arg-types tagged-num (:constant (signed-byte 30)))
 908   (:info target not-p y)
 909   (:translate eql)
 910   (:generator 2
 911     (cond ((and (sc-is x any-reg) (zerop y))
 912            (inst test x x))  ; smaller instruction
 913           (t
 914            (inst cmp x (fixnumize y))))
 915     (inst jmp (if not-p :ne :e) target)))
 916 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
 917   (:args (x :scs (any-reg descriptor-reg control-stack)))
 918   (:arg-types * (:constant (signed-byte 30)))
 919   (:variant-cost 6))
 920 \f
 921 ;;;; 32-bit logical operations
 922
 923 (define-vop (merge-bits)
 924   (:translate merge-bits)
 925   (:args (shift :scs (signed-reg unsigned-reg) :target ecx)
 926          (prev :scs (unsigned-reg) :target result)
 927          (next :scs (unsigned-reg)))
 928   (:arg-types tagged-num unsigned-num unsigned-num)
 929   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 0)) ecx)
 930   (:results (result :scs (unsigned-reg) :from (:argument 1)))
 931   (:result-types unsigned-num)
 932   (:policy :fast-safe)
 933   (:generator 4
 934     (move ecx shift)
 935     (move result prev)
 936     (inst shrd result next :cl)))
 937
 938 (define-vop (32bit-logical)
 939   (:args (x :scs (unsigned-reg) :target r
 940             :load-if (not (and (sc-is x unsigned-stack)
 941                                (sc-is r unsigned-stack)
 942                                (location= x r))))
 943          (y :scs (unsigned-reg)
 944             :load-if (or (not (sc-is y unsigned-stack))
 945                          (and (sc-is x unsigned-stack)
 946                               (sc-is y unsigned-stack)
 947                               (location= x r)))))
 948   (:arg-types unsigned-num unsigned-num)
 949   (:results (r :scs (unsigned-reg)
 950                :from (:argument 0)
 951                :load-if (not (and (sc-is x unsigned-stack)
 952                                   (sc-is r unsigned-stack)
 953                                   (location= x r)))))
 954   (:result-types unsigned-num)
 955   (:policy :fast-safe))
 956
 957 (define-vop (32bit-logical-not)
 958   (:translate 32bit-logical-not)
 959   (:args (x :scs (unsigned-reg) :target r
 960             :load-if (not (and (sc-is x unsigned-stack)
 961                                (sc-is r unsigned-stack)
 962                                (location= x r)))))
 963   (:arg-types unsigned-num)
 964   (:results (r :scs (unsigned-reg)
 965                :load-if (not (and (sc-is x unsigned-stack)
 966                                   (sc-is r unsigned-stack)
 967                                   (location= x r)))))
 968   (:result-types unsigned-num)
 969   (:policy :fast-safe)
 970   (:generator 1
 971     (move r x)
 972     (inst not r)))
 973
 974 (define-vop (32bit-logical-and 32bit-logical)
 975   (:translate 32bit-logical-and)
 976   (:generator 1
 977     (move r x)
 978     (inst and r y)))
 979
 980 (def-source-transform 32bit-logical-nand (x y)
 981   `(32bit-logical-not (32bit-logical-and ,x ,y)))
 982
 983 (define-vop (32bit-logical-or 32bit-logical)
 984   (:translate 32bit-logical-or)
 985   (:generator 1
 986     (move r x)
 987     (inst or r y)))
 988
 989 (def-source-transform 32bit-logical-nor (x y)
 990   `(32bit-logical-not (32bit-logical-or ,x ,y)))
 991
 992 (define-vop (32bit-logical-xor 32bit-logical)
 993   (:translate 32bit-logical-xor)
 994   (:generator 1
 995     (move r x)
 996     (inst xor r y)))
 997
 998 (def-source-transform 32bit-logical-eqv (x y)
 999   `(32bit-logical-not (32bit-logical-xor ,x ,y)))
1000
1001 (def-source-transform 32bit-logical-orc1 (x y)
1002   `(32bit-logical-or (32bit-logical-not ,x) ,y))
1003
1004 (def-source-transform 32bit-logical-orc2 (x y)
1005   `(32bit-logical-or ,x (32bit-logical-not ,y)))
1006
1007 (def-source-transform 32bit-logical-andc1 (x y)
1008   `(32bit-logical-and (32bit-logical-not ,x) ,y))
1009
1010 (def-source-transform 32bit-logical-andc2 (x y)
1011   `(32bit-logical-and ,x (32bit-logical-not ,y)))
1012
1013 ;;; Only the lower 5 bits of the shift amount are significant.
1014 (define-vop (shift-towards-someplace)
1015   (:policy :fast-safe)
1016   (:args (num :scs (unsigned-reg) :target r)
1017          (amount :scs (signed-reg) :target ecx))
1018   (:arg-types unsigned-num tagged-num)
1019   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
1020   (:results (r :scs (unsigned-reg) :from (:argument 0)))
1021   (:result-types unsigned-num))
1022
1023 (define-vop (shift-towards-start shift-towards-someplace)
1024   (:translate shift-towards-start)
1025   (:note "SHIFT-TOWARDS-START")
1026   (:generator 1
1027     (move r num)
1028     (move ecx amount)
1029     (inst shr r :cl)))
1030
1031 (define-vop (shift-towards-end shift-towards-someplace)
1032   (:translate shift-towards-end)
1033   (:note "SHIFT-TOWARDS-END")
1034   (:generator 1
1035     (move r num)
1036     (move ecx amount)
1037     (inst shl r :cl)))
1038 \f
1039 ;;;; bignum stuff
1040
1041 (define-vop (bignum-length get-header-data)
1042   (:translate sb!bignum::%bignum-length)
1043   (:policy :fast-safe))
1044
1045 (define-vop (bignum-set-length set-header-data)
1046   (:translate sb!bignum::%bignum-set-length)
1047   (:policy :fast-safe))
1048
1049 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type
1050   (unsigned-reg) unsigned-num sb!bignum::%bignum-ref)
1051
1052 (define-full-setter bignum-set * bignum-digits-offset other-pointer-type
1053   (unsigned-reg) unsigned-num sb!bignum::%bignum-set)
1054
1055 (define-vop (digit-0-or-plus)
1056   (:translate sb!bignum::%digit-0-or-plusp)
1057   (:policy :fast-safe)
1058   (:args (digit :scs (unsigned-reg)))
1059   (:arg-types unsigned-num)
1060   (:conditional)
1061   (:info target not-p)
1062   (:generator 3
1063     (inst or digit digit)
1064     (inst jmp (if not-p :s :ns) target)))
1065
1066
1067 ;;; For add and sub with carry the sc of carry argument is any-reg so
1068 ;;; the it may be passed as a fixnum or word and thus may be 0, 1, or
1069 ;;; 4. This is easy to deal with and may save a fixnum-word
1070 ;;; conversion.
1071 (define-vop (add-w/carry)
1072   (:translate sb!bignum::%add-with-carry)
1073   (:policy :fast-safe)
1074   (:args (a :scs (unsigned-reg) :target result)
1075          (b :scs (unsigned-reg unsigned-stack) :to :eval)
1076          (c :scs (any-reg) :target temp))
1077   (:arg-types unsigned-num unsigned-num positive-fixnum)
1078   (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
1079   (:results (result :scs (unsigned-reg) :from (:argument 0))
1080             (carry :scs (unsigned-reg)))
1081   (:result-types unsigned-num positive-fixnum)
1082   (:generator 4
1083     (move result a)
1084     (move temp c)
1085     (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
1086     (inst adc result b)
1087     (inst mov carry 0)
1088     (inst adc carry carry)))
1089
1090 ;;; Note: the borrow is the oppostite of the x86 convention - 1 for no
1091 ;;; borrow and 0 for a borrow.
1092 (define-vop (sub-w/borrow)
1093   (:translate sb!bignum::%subtract-with-borrow)
1094   (:policy :fast-safe)
1095   (:args (a :scs (unsigned-reg) :to :eval :target result)
1096          (b :scs (unsigned-reg unsigned-stack) :to :result)
1097          (c :scs (any-reg control-stack)))
1098   (:arg-types unsigned-num unsigned-num positive-fixnum)
1099   (:results (result :scs (unsigned-reg) :from :eval)
1100             (borrow :scs (unsigned-reg)))
1101   (:result-types unsigned-num positive-fixnum)
1102   (:generator 5
1103     (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
1104     (move result a)
1105     (inst sbb result b)
1106     (inst mov borrow 0)
1107     (inst adc borrow borrow)
1108     (inst xor borrow 1)))
1109
1110
1111 (define-vop (bignum-mult-and-add-3-arg)
1112   (:translate sb!bignum::%multiply-and-add)
1113   (:policy :fast-safe)
1114   (:args (x :scs (unsigned-reg) :target eax)
1115          (y :scs (unsigned-reg unsigned-stack))
1116          (carry-in :scs (unsigned-reg unsigned-stack)))
1117   (:arg-types unsigned-num unsigned-num unsigned-num)
1118   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1119                    :to (:result 1) :target lo) eax)
1120   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1121                    :to (:result 0) :target hi) edx)
1122   (:results (hi :scs (unsigned-reg))
1123             (lo :scs (unsigned-reg)))
1124   (:result-types unsigned-num unsigned-num)
1125   (:generator 20
1126     (move eax x)
1127     (inst mul eax y)
1128     (inst add eax carry-in)
1129     (inst adc edx 0)
1130     (move hi edx)
1131     (move lo eax)))
1132
1133 (define-vop (bignum-mult-and-add-4-arg)
1134   (:translate sb!bignum::%multiply-and-add)
1135   (:policy :fast-safe)
1136   (:args (x :scs (unsigned-reg) :target eax)
1137          (y :scs (unsigned-reg unsigned-stack))
1138          (prev :scs (unsigned-reg unsigned-stack))
1139          (carry-in :scs (unsigned-reg unsigned-stack)))
1140   (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1141   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1142                    :to (:result 1) :target lo) eax)
1143   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1144                    :to (:result 0) :target hi) edx)
1145   (:results (hi :scs (unsigned-reg))
1146             (lo :scs (unsigned-reg)))
1147   (:result-types unsigned-num unsigned-num)
1148   (:generator 20
1149     (move eax x)
1150     (inst mul eax y)
1151     (inst add eax prev)
1152     (inst adc edx 0)
1153     (inst add eax carry-in)
1154     (inst adc edx 0)
1155     (move hi edx)
1156     (move lo eax)))
1157
1158
1159 (define-vop (bignum-mult)
1160   (:translate sb!bignum::%multiply)
1161   (:policy :fast-safe)
1162   (:args (x :scs (unsigned-reg) :target eax)
1163          (y :scs (unsigned-reg unsigned-stack)))
1164   (:arg-types unsigned-num unsigned-num)
1165   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1166                    :to (:result 1) :target lo) eax)
1167   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1168                    :to (:result 0) :target hi) edx)
1169   (:results (hi :scs (unsigned-reg))
1170             (lo :scs (unsigned-reg)))
1171   (:result-types unsigned-num unsigned-num)
1172   (:generator 20
1173     (move eax x)
1174     (inst mul eax y)
1175     (move hi edx)
1176     (move lo eax)))
1177
1178 (define-vop (bignum-lognot)
1179   (:translate sb!bignum::%lognot)
1180   (:policy :fast-safe)
1181   (:args (x :scs (unsigned-reg unsigned-stack) :target r))
1182   (:arg-types unsigned-num)
1183   (:results (r :scs (unsigned-reg)
1184                :load-if (not (location= x r))))
1185   (:result-types unsigned-num)
1186   (:generator 1
1187     (move r x)
1188     (inst not r)))
1189
1190 (define-vop (fixnum-to-digit)
1191   (:translate sb!bignum::%fixnum-to-digit)
1192   (:policy :fast-safe)
1193   (:args (fixnum :scs (any-reg control-stack) :target digit))
1194   (:arg-types tagged-num)
1195   (:results (digit :scs (unsigned-reg)
1196                    :load-if (not (and (sc-is fixnum control-stack)
1197                                       (sc-is digit unsigned-stack)
1198                                       (location= fixnum digit)))))
1199   (:result-types unsigned-num)
1200   (:generator 1
1201     (move digit fixnum)
1202     (inst sar digit 2)))
1203
1204 (define-vop (bignum-floor)
1205   (:translate sb!bignum::%floor)
1206   (:policy :fast-safe)
1207   (:args (div-high :scs (unsigned-reg) :target edx)
1208          (div-low :scs (unsigned-reg) :target eax)
1209          (divisor :scs (unsigned-reg unsigned-stack)))
1210   (:arg-types unsigned-num unsigned-num unsigned-num)
1211   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
1212                    :to (:result 0) :target quo) eax)
1213   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
1214                    :to (:result 1) :target rem) edx)
1215   (:results (quo :scs (unsigned-reg))
1216             (rem :scs (unsigned-reg)))
1217   (:result-types unsigned-num unsigned-num)
1218   (:generator 300
1219     (move edx div-high)
1220     (move eax div-low)
1221     (inst div eax divisor)
1222     (move quo eax)
1223     (move rem edx)))
1224
1225 (define-vop (signify-digit)
1226   (:translate sb!bignum::%fixnum-digit-with-correct-sign)
1227   (:policy :fast-safe)
1228   (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
1229   (:arg-types unsigned-num)
1230   (:results (res :scs (any-reg signed-reg)
1231                  :load-if (not (and (sc-is digit unsigned-stack)
1232                                     (sc-is res control-stack signed-stack)
1233                                     (location= digit res)))))
1234   (:result-types signed-num)
1235   (:generator 1
1236     (move res digit)
1237     (when (sc-is res any-reg control-stack)
1238       (inst shl res 2))))
1239
1240 (define-vop (digit-ashr)
1241   (:translate sb!bignum::%ashr)
1242   (:policy :fast-safe)
1243   (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
1244          (count :scs (unsigned-reg) :target ecx))
1245   (:arg-types unsigned-num positive-fixnum)
1246   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
1247   (:results (result :scs (unsigned-reg) :from (:argument 0)
1248                     :load-if (not (and (sc-is result unsigned-stack)
1249                                        (location= digit result)))))
1250   (:result-types unsigned-num)
1251   (:generator 1
1252     (move result digit)
1253     (move ecx count)
1254     (inst sar result :cl)))
1255
1256 (define-vop (digit-lshr digit-ashr)
1257   (:translate sb!bignum::%digit-logical-shift-right)
1258   (:generator 1
1259     (move result digit)
1260     (move ecx count)
1261     (inst shr result :cl)))
1262
1263 (define-vop (digit-ashl digit-ashr)
1264   (:translate sb!bignum::%ashl)
1265   (:generator 1
1266     (move result digit)
1267     (move ecx count)
1268     (inst shl result :cl)))
1269 \f
1270 ;;;; static functions
1271
1272 (define-static-function two-arg-/ (x y) :translate /)
1273
1274 (define-static-function two-arg-gcd (x y) :translate gcd)
1275 (define-static-function two-arg-lcm (x y) :translate lcm)
1276
1277 (define-static-function two-arg-and (x y) :translate logand)
1278 (define-static-function two-arg-ior (x y) :translate logior)
1279 (define-static-function two-arg-xor (x y) :translate logxor)
1280
1281 \f
1282 ;;; Support for the Mersenne Twister, MT19937, random number generator
1283 ;;; due to Matsumoto and Nishimura.
1284 ;;;
1285 ;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A
1286 ;;; 623-dimensionally equidistributed uniform pseudorandom number
1287 ;;; generator.", ACM Transactions on Modeling and Computer Simulation,
1288 ;;; 1997, to appear.
1289 ;;;
1290 ;;; State:
1291 ;;;  0-1:   Constant matrix A. [0, #x9908b0df] (not used here)
1292 ;;;  2:     Index; init. to 1.
1293 ;;;  3-626: State.
1294 (defknown random-mt19937 ((simple-array (unsigned-byte 32) (*)))
1295   (unsigned-byte 32) ())
1296 (define-vop (random-mt19937)
1297   (:policy :fast-safe)
1298   (:translate random-mt19937)
1299   (:args (state :scs (descriptor-reg) :to :result))
1300   (:arg-types simple-array-unsigned-byte-32)
1301   (:temporary (:sc unsigned-reg :from (:eval 0) :to :result) k)
1302   (:temporary (:sc unsigned-reg :offset eax-offset
1303                    :from (:eval 0) :to :result) tmp)
1304   (:results (y :scs (unsigned-reg) :from (:eval 0)))
1305   (:result-types unsigned-num)
1306   (:generator 50
1307     (inst mov k (make-ea :dword :base state
1308                          :disp (- (* (+ 2 sb!vm:vector-data-offset)
1309                                      sb!vm:word-bytes)
1310                                   sb!vm:other-pointer-type)))
1311     (inst cmp k 624)
1312     (inst jmp :ne no-update)
1313     (inst mov tmp state)        ; The state is passed in EAX.
1314     (inst call (make-fixup 'random-mt19937-update :assembly-routine))
1315     ;; Restore k, and set to 0.
1316     (inst xor k k)
1317     NO-UPDATE
1318     ;; y = ptgfsr[k++];
1319     (inst mov y (make-ea :dword :base state :index k :scale 4
1320                          :disp (- (* (+ 3 sb!vm:vector-data-offset)
1321                                      sb!vm:word-bytes)
1322                                   sb!vm:other-pointer-type)))
1323     ;; y ^= (y >> 11);
1324     (inst shr y 11)
1325     (inst xor y (make-ea :dword :base state :index k :scale 4
1326                          :disp (- (* (+ 3 sb!vm:vector-data-offset)
1327                                      sb!vm:word-bytes)
1328                                   sb!vm:other-pointer-type)))
1329     ;; y ^= (y << 7) & #x9d2c5680
1330     (inst mov tmp y)
1331     (inst inc k)
1332     (inst shl tmp 7)
1333     (inst mov (make-ea :dword :base state
1334                        :disp (- (* (+ 2 sb!vm:vector-data-offset)
1335                                    sb!vm:word-bytes)
1336                                 sb!vm:other-pointer-type))
1337           k)
1338     (inst and tmp #x9d2c5680)
1339     (inst xor y tmp)
1340     ;; y ^= (y << 15) & #xefc60000
1341     (inst mov tmp y)
1342     (inst shl tmp 15)
1343     (inst and tmp #xefc60000)
1344     (inst xor y tmp)
1345     ;; y ^= (y >> 18);
1346     (inst mov tmp y)
1347     (inst shr tmp 18)
1348     (inst xor y tmp)))