src/compiler/x86/arith.lisp

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