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   (:generator 2
 601     (cond ((and (= amount 1) (not (location= number result)))
 602            (inst lea result (make-ea :dword :base number :index number)))
 603           ((and (= amount 2) (not (location= number result)))
 604            (inst lea result (make-ea :dword :index number :scale 4)))
 605           ((and (= amount 3) (not (location= number result)))
 606            (inst lea result (make-ea :dword :index number :scale 8)))
 607           (t
 608            (move result number)
 609            (cond ((< -32 amount 32)
 610                   ;; this code is used both in ASH and ASH-SMOD30, so
 611                   ;; be careful
 612                   (if (plusp amount)
 613                       (inst shl result amount)
 614                       (progn
 615                         (inst sar result (- amount))
 616                         (inst and result (lognot fixnum-tag-mask)))))
 617                  ((plusp amount)
 618                   (if (sc-is result any-reg)
 619                       (inst xor result result)
 620                       (inst mov result 0)))
 621                  (t (inst sar result 31)
 622                     (inst and result (lognot fixnum-tag-mask))))))))
 623
 624 (define-vop (fast-ash-left/fixnum=>fixnum)
 625   (:translate ash)
 626   (:args (number :scs (any-reg) :target result
 627                  :load-if (not (and (sc-is number control-stack)
 628                                     (sc-is result control-stack)
 629                                     (location= number result))))
 630          (amount :scs (unsigned-reg) :target ecx))
 631   (:arg-types tagged-num positive-fixnum)
 632   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
 633   (:results (result :scs (any-reg) :from (:argument 0)
 634                     :load-if (not (and (sc-is number control-stack)
 635                                        (sc-is result control-stack)
 636                                        (location= number result)))))
 637   (:result-types tagged-num)
 638   (:policy :fast-safe)
 639   (:note "inline ASH")
 640   (:generator 3
 641     (move result number)
 642     (move ecx amount)
 643     ;; The result-type ensures us that this shift will not overflow.
 644     (inst shl result :cl)))
 645
 646 (define-vop (fast-ash-c/signed=>signed)
 647   (:translate ash)
 648   (:policy :fast-safe)
 649   (:args (number :scs (signed-reg) :target result
 650                  :load-if (not (and (sc-is number signed-stack)
 651                                     (sc-is result signed-stack)
 652                                     (location= number result)))))
 653   (:info amount)
 654   (:arg-types signed-num (:constant integer))
 655   (:results (result :scs (signed-reg)
 656                     :load-if (not (and (sc-is number signed-stack)
 657                                        (sc-is result signed-stack)
 658                                        (location= number result)))))
 659   (:result-types signed-num)
 660   (:note "inline ASH")
 661   (:generator 3
 662     (cond ((and (= amount 1) (not (location= number result)))
 663            (inst lea result (make-ea :dword :base number :index number)))
 664           ((and (= amount 2) (not (location= number result)))
 665            (inst lea result (make-ea :dword :index number :scale 4)))
 666           ((and (= amount 3) (not (location= number result)))
 667            (inst lea result (make-ea :dword :index number :scale 8)))
 668           (t
 669            (move result number)
 670            (cond ((plusp amount) (inst shl result amount))
 671                  (t (inst sar result (min 31 (- amount)))))))))
 672
 673 (define-vop (fast-ash-c/unsigned=>unsigned)
 674   (:translate ash)
 675   (:policy :fast-safe)
 676   (:args (number :scs (unsigned-reg) :target result
 677                  :load-if (not (and (sc-is number unsigned-stack)
 678                                     (sc-is result unsigned-stack)
 679                                     (location= number result)))))
 680   (:info amount)
 681   (:arg-types unsigned-num (:constant integer))
 682   (:results (result :scs (unsigned-reg)
 683                     :load-if (not (and (sc-is number unsigned-stack)
 684                                        (sc-is result unsigned-stack)
 685                                        (location= number result)))))
 686   (:result-types unsigned-num)
 687   (:note "inline ASH")
 688   (:generator 3
 689     (cond ((and (= amount 1) (not (location= number result)))
 690            (inst lea result (make-ea :dword :base number :index number)))
 691           ((and (= amount 2) (not (location= number result)))
 692            (inst lea result (make-ea :dword :index number :scale 4)))
 693           ((and (= amount 3) (not (location= number result)))
 694            (inst lea result (make-ea :dword :index number :scale 8)))
 695           (t
 696            (move result number)
 697            (cond ((< -32 amount 32)
 698                   ;; this code is used both in ASH and ASH-MOD32, so
 699                   ;; be careful
 700                   (if (plusp amount)
 701                       (inst shl result amount)
 702                       (inst shr result (- amount))))
 703                  (t (if (sc-is result unsigned-reg)
 704                         (inst xor result result)
 705                         (inst mov result 0))))))))
 706
 707 (define-vop (fast-ash-left/signed=>signed)
 708   (:translate ash)
 709   (:args (number :scs (signed-reg) :target result
 710                  :load-if (not (and (sc-is number signed-stack)
 711                                     (sc-is result signed-stack)
 712                                     (location= number result))))
 713          (amount :scs (unsigned-reg) :target ecx))
 714   (:arg-types signed-num positive-fixnum)
 715   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
 716   (:results (result :scs (signed-reg) :from (:argument 0)
 717                     :load-if (not (and (sc-is number signed-stack)
 718                                        (sc-is result signed-stack)
 719                                        (location= number result)))))
 720   (:result-types signed-num)
 721   (:policy :fast-safe)
 722   (:note "inline ASH")
 723   (:generator 4
 724     (move result number)
 725     (move ecx amount)
 726     (inst shl result :cl)))
 727
 728 (define-vop (fast-ash-left/unsigned=>unsigned)
 729   (:translate ash)
 730   (:args (number :scs (unsigned-reg) :target result
 731                  :load-if (not (and (sc-is number unsigned-stack)
 732                                     (sc-is result unsigned-stack)
 733                                     (location= number result))))
 734          (amount :scs (unsigned-reg) :target ecx))
 735   (:arg-types unsigned-num positive-fixnum)
 736   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
 737   (:results (result :scs (unsigned-reg) :from (:argument 0)
 738                     :load-if (not (and (sc-is number unsigned-stack)
 739                                        (sc-is result unsigned-stack)
 740                                        (location= number result)))))
 741   (:result-types unsigned-num)
 742   (:policy :fast-safe)
 743   (:note "inline ASH")
 744   (:generator 4
 745     (move result number)
 746     (move ecx amount)
 747     (inst shl result :cl)))
 748
 749 (define-vop (fast-ash/signed=>signed)
 750   (:translate ash)
 751   (:policy :fast-safe)
 752   (:args (number :scs (signed-reg) :target result)
 753          (amount :scs (signed-reg) :target ecx))
 754   (:arg-types signed-num signed-num)
 755   (:results (result :scs (signed-reg) :from (:argument 0)))
 756   (:result-types signed-num)
 757   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
 758   (:note "inline ASH")
 759   (:generator 5
 760     (move result number)
 761     (move ecx amount)
 762     (inst or ecx ecx)
 763     (inst jmp :ns positive)
 764     (inst neg ecx)
 765     (inst cmp ecx 31)
 766     (inst jmp :be okay)
 767     (inst mov ecx 31)
 768     OKAY
 769     (inst sar result :cl)
 770     (inst jmp done)
 771
 772     POSITIVE
 773     ;; The result-type ensures us that this shift will not overflow.
 774     (inst shl result :cl)
 775
 776     DONE))
 777
 778 (define-vop (fast-ash/unsigned=>unsigned)
 779   (:translate ash)
 780   (:policy :fast-safe)
 781   (:args (number :scs (unsigned-reg) :target result)
 782          (amount :scs (signed-reg) :target ecx))
 783   (:arg-types unsigned-num signed-num)
 784   (:results (result :scs (unsigned-reg) :from (:argument 0)))
 785   (:result-types unsigned-num)
 786   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
 787   (:note "inline ASH")
 788   (:generator 5
 789     (move result number)
 790     (move ecx amount)
 791     (inst or ecx ecx)
 792     (inst jmp :ns positive)
 793     (inst neg ecx)
 794     (inst cmp ecx 31)
 795     (inst jmp :be okay)
 796     (inst xor result result)
 797     (inst jmp done)
 798     OKAY
 799     (inst shr result :cl)
 800     (inst jmp done)
 801
 802     POSITIVE
 803     ;; The result-type ensures us that this shift will not overflow.
 804     (inst shl result :cl)
 805
 806     DONE))
 807
 808 (in-package "SB!C")
 809
 810 (defknown %lea (integer integer (member 1 2 4 8) (signed-byte 32))
 811   integer
 812   (foldable flushable movable))
 813
 814 (defoptimizer (%lea derive-type) ((base index scale disp))
 815   (when (and (constant-lvar-p scale)
 816              (constant-lvar-p disp))
 817     (let ((scale (lvar-value scale))
 818           (disp (lvar-value disp))
 819           (base-type (lvar-type base))
 820           (index-type (lvar-type index)))
 821       (when (and (numeric-type-p base-type)
 822                  (numeric-type-p index-type))
 823         (let ((base-lo (numeric-type-low base-type))
 824               (base-hi (numeric-type-high base-type))
 825               (index-lo (numeric-type-low index-type))
 826               (index-hi (numeric-type-high index-type)))
 827           (make-numeric-type :class 'integer
 828                              :complexp :real
 829                              :low (when (and base-lo index-lo)
 830                                     (+ base-lo (* index-lo scale) disp))
 831                              :high (when (and base-hi index-hi)
 832                                      (+ base-hi (* index-hi scale) disp))))))))
 833
 834 (defun %lea (base index scale disp)
 835   (+ base (* index scale) disp))
 836
 837 (in-package "SB!VM")
 838
 839 (define-vop (%lea/unsigned=>unsigned)
 840   (:translate %lea)
 841   (:policy :fast-safe)
 842   (:args (base :scs (unsigned-reg))
 843          (index :scs (unsigned-reg)))
 844   (:info scale disp)
 845   (:arg-types unsigned-num unsigned-num
 846               (:constant (member 1 2 4 8))
 847               (:constant (signed-byte 32)))
 848   (:results (r :scs (unsigned-reg)))
 849   (:result-types unsigned-num)
 850   (:generator 5
 851     (inst lea r (make-ea :dword :base base :index index
 852                          :scale scale :disp disp))))
 853
 854 (define-vop (%lea/signed=>signed)
 855   (:translate %lea)
 856   (:policy :fast-safe)
 857   (:args (base :scs (signed-reg))
 858          (index :scs (signed-reg)))
 859   (:info scale disp)
 860   (:arg-types signed-num signed-num
 861               (:constant (member 1 2 4 8))
 862               (:constant (signed-byte 32)))
 863   (:results (r :scs (signed-reg)))
 864   (:result-types signed-num)
 865   (:generator 4
 866     (inst lea r (make-ea :dword :base base :index index
 867                          :scale scale :disp disp))))
 868
 869 (define-vop (%lea/fixnum=>fixnum)
 870   (:translate %lea)
 871   (:policy :fast-safe)
 872   (:args (base :scs (any-reg))
 873          (index :scs (any-reg)))
 874   (:info scale disp)
 875   (:arg-types tagged-num tagged-num
 876               (:constant (member 1 2 4 8))
 877               (:constant (signed-byte 32)))
 878   (:results (r :scs (any-reg)))
 879   (:result-types tagged-num)
 880   (:generator 3
 881     (inst lea r (make-ea :dword :base base :index index
 882                          :scale scale :disp disp))))
 883
 884 ;;; FIXME: before making knowledge of this too public, it needs to be
 885 ;;; fixed so that it's actually _faster_ than the non-CMOV version; at
 886 ;;; least on my Celeron-XXX laptop, this version is marginally slower
 887 ;;; than the above version with branches.  -- CSR, 2003-09-04
 888 (define-vop (fast-cmov-ash/unsigned=>unsigned)
 889   (:translate ash)
 890   (:policy :fast-safe)
 891   (:args (number :scs (unsigned-reg) :target result)
 892          (amount :scs (signed-reg) :target ecx))
 893   (:arg-types unsigned-num signed-num)
 894   (:results (result :scs (unsigned-reg) :from (:argument 0)))
 895   (:result-types unsigned-num)
 896   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
 897   (:temporary (:sc any-reg :from (:eval 0) :to (:eval 1)) zero)
 898   (:note "inline ASH")
 899   (:guard (member :cmov *backend-subfeatures*))
 900   (:generator 4
 901     (move result number)
 902     (move ecx amount)
 903     (inst or ecx ecx)
 904     (inst jmp :ns positive)
 905     (inst neg ecx)
 906     (inst xor zero zero)
 907     (inst shr result :cl)
 908     (inst cmp ecx 31)
 909     (inst cmov :nbe result zero)
 910     (inst jmp done)
 911
 912     POSITIVE
 913     ;; The result-type ensures us that this shift will not overflow.
 914     (inst shl result :cl)
 915
 916     DONE))
 917 \f
 918 (define-vop (signed-byte-32-len)
 919   (:translate integer-length)
 920   (:note "inline (signed-byte 32) integer-length")
 921   (:policy :fast-safe)
 922   (:args (arg :scs (signed-reg) :target res))
 923   (:arg-types signed-num)
 924   (:results (res :scs (unsigned-reg)))
 925   (:result-types unsigned-num)
 926   (:generator 28
 927     (move res arg)
 928     (if (sc-is res unsigned-reg)
 929         (inst test res res)
 930         (inst cmp res 0))
 931     (inst jmp :ge POS)
 932     (inst not res)
 933     POS
 934     (inst bsr res res)
 935     (inst jmp :z zero)
 936     (inst inc res)
 937     (inst jmp done)
 938     ZERO
 939     (inst xor res res)
 940     DONE))
 941
 942 (define-vop (unsigned-byte-32-len)
 943   (:translate integer-length)
 944   (:note "inline (unsigned-byte 32) integer-length")
 945   (:policy :fast-safe)
 946   (:args (arg :scs (unsigned-reg)))
 947   (:arg-types unsigned-num)
 948   (:results (res :scs (unsigned-reg)))
 949   (:result-types unsigned-num)
 950   (:generator 26
 951     (inst bsr res arg)
 952     (inst jmp :z zero)
 953     (inst inc res)
 954     (inst jmp done)
 955     ZERO
 956     (inst xor res res)
 957     DONE))
 958
 959 (define-vop (unsigned-byte-32-count)
 960   (:translate logcount)
 961   (:note "inline (unsigned-byte 32) logcount")
 962   (:policy :fast-safe)
 963   (:args (arg :scs (unsigned-reg) :target result))
 964   (:arg-types unsigned-num)
 965   (:results (result :scs (unsigned-reg)))
 966   (:result-types positive-fixnum)
 967   (:temporary (:sc unsigned-reg) temp)
 968   (:generator 14
 969     ;; See the comments below for how the algorithm works. The tricks
 970     ;; used can be found for example in AMD's software optimization
 971     ;; guide or at "http://www.hackersdelight.org/HDcode/pop.cc" in the
 972     ;; function "pop1".
 973     ;; Calculate 2-bit sums. Note that the value of a two-digit binary
 974     ;; number is the sum of the right digit and twice the left digit.
 975     ;; Thus we can calculate the sum of the two digits by shifting the
 976     ;; left digit to the right position and doing a two-bit subtraction.
 977     ;; This subtraction will never create a borrow and thus can be made
 978     ;; on all 16 2-digit numbers at once.
 979     (move result arg)
 980     (move temp arg)
 981     (inst shr result 1)
 982     (inst and result #x55555555)
 983     (inst sub temp result)
 984     ;; Calculate 4-bit sums by straightforward shift, mask and add.
 985     ;; Note that we shift the source operand of the MOV and not its
 986     ;; destination so that the SHR and the MOV can execute in the same
 987     ;; clock cycle.
 988     (inst mov result temp)
 989     (inst shr temp 2)
 990     (inst and result #x33333333)
 991     (inst and temp #x33333333)
 992     (inst add result temp)
 993     ;; Calculate 8-bit sums. Since each sum is at most 8, which fits
 994     ;; into 4 bits, we can apply the mask after the addition, saving one
 995     ;; instruction.
 996     (inst mov temp result)
 997     (inst shr result 4)
 998     (inst add result temp)
 999     (inst and result #x0f0f0f0f)
1000     ;; Calculate the two 16-bit sums and the 32-bit sum. No masking is
1001     ;; necessary inbetween since the final sum is at most 32 which fits
1002     ;; into 6 bits.
1003     (inst mov temp result)
1004     (inst shr result 8)
1005     (inst add result temp)
1006     (inst mov temp result)
1007     (inst shr result 16)
1008     (inst add result temp)
1009     (inst and result #xff)))
1010 \f
1011 ;;;; binary conditional VOPs
1012
1013 (define-vop (fast-conditional)
1014   (:conditional :e)
1015   (:effects)
1016   (:affected)
1017   (:policy :fast-safe))
1018
1019 (define-vop (fast-conditional/fixnum fast-conditional)
1020   (:args (x :scs (any-reg)
1021             :load-if (not (and (sc-is x control-stack)
1022                                (sc-is y any-reg))))
1023          (y :scs (any-reg control-stack)))
1024   (:arg-types tagged-num tagged-num)
1025   (:note "inline fixnum comparison"))
1026
1027 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
1028   (:args (x :scs (any-reg control-stack)))
1029   (:arg-types tagged-num (:constant (signed-byte 30)))
1030   (:info y))
1031
1032 (define-vop (fast-conditional/signed fast-conditional)
1033   (:args (x :scs (signed-reg)
1034             :load-if (not (and (sc-is x signed-stack)
1035                                (sc-is y signed-reg))))
1036          (y :scs (signed-reg signed-stack)))
1037   (:arg-types signed-num signed-num)
1038   (:note "inline (signed-byte 32) comparison"))
1039
1040 (define-vop (fast-conditional-c/signed fast-conditional/signed)
1041   (:args (x :scs (signed-reg signed-stack)))
1042   (:arg-types signed-num (:constant (signed-byte 32)))
1043   (:info y))
1044
1045 (define-vop (fast-conditional/unsigned fast-conditional)
1046   (:args (x :scs (unsigned-reg)
1047             :load-if (not (and (sc-is x unsigned-stack)
1048                                (sc-is y unsigned-reg))))
1049          (y :scs (unsigned-reg unsigned-stack)))
1050   (:arg-types unsigned-num unsigned-num)
1051   (:note "inline (unsigned-byte 32) comparison"))
1052
1053 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
1054   (:args (x :scs (unsigned-reg unsigned-stack)))
1055   (:arg-types unsigned-num (:constant (unsigned-byte 32)))
1056   (:info y))
1057
1058 (macrolet ((define-logtest-vops ()
1059              `(progn
1060                ,@(loop for suffix in '(/fixnum -c/fixnum
1061                                        /signed -c/signed
1062                                        /unsigned -c/unsigned)
1063                        for cost in '(4 3 6 5 6 5)
1064                        collect
1065                        `(define-vop (,(symbolicate "FAST-LOGTEST" suffix)
1066                                      ,(symbolicate "FAST-CONDITIONAL" suffix))
1067                          (:translate logtest)
1068                          (:conditional :ne)
1069                          (:generator ,cost
1070                           (emit-optimized-test-inst x
1071                                                     ,(if (eq suffix '-c/fixnum)
1072                                                          '(fixnumize y)
1073                                                          'y))))))))
1074   (define-logtest-vops))
1075
1076 (defknown %logbitp (integer unsigned-byte) boolean
1077   (movable foldable flushable always-translatable))
1078
1079 ;;; only for constant folding within the compiler
1080 (defun %logbitp (integer index)
1081   (logbitp index integer))
1082
1083 ;;; too much work to do the non-constant case (maybe?)
1084 (define-vop (fast-logbitp-c/fixnum fast-conditional-c/fixnum)
1085   (:translate %logbitp)
1086   (:conditional :c)
1087   (:arg-types tagged-num (:constant (integer 0 29)))
1088   (:generator 4
1089     (inst bt x (+ y n-fixnum-tag-bits))))
1090
1091 (define-vop (fast-logbitp/signed fast-conditional/signed)
1092   (:args (x :scs (signed-reg signed-stack))
1093          (y :scs (signed-reg)))
1094   (:translate %logbitp)
1095   (:conditional :c)
1096   (:generator 6
1097     (inst bt x y)))
1098
1099 (define-vop (fast-logbitp-c/signed fast-conditional-c/signed)
1100   (:translate %logbitp)
1101   (:conditional :c)
1102   (:arg-types signed-num (:constant (integer 0 31)))
1103   (:generator 5
1104     (inst bt x y)))
1105
1106 (define-vop (fast-logbitp/unsigned fast-conditional/unsigned)
1107   (:args (x :scs (unsigned-reg unsigned-stack))
1108          (y :scs (unsigned-reg)))
1109   (:translate %logbitp)
1110   (:conditional :c)
1111   (:generator 6
1112     (inst bt x y)))
1113
1114 (define-vop (fast-logbitp-c/unsigned fast-conditional-c/unsigned)
1115   (:translate %logbitp)
1116   (:conditional :c)
1117   (:arg-types unsigned-num (:constant (integer 0 31)))
1118   (:generator 5
1119     (inst bt x y)))
1120
1121 (macrolet ((define-conditional-vop (tran cond unsigned)
1122              `(progn
1123                 ,@(mapcar
1124                    (lambda (suffix cost signed)
1125                      `(define-vop (;; FIXME: These could be done more
1126                                    ;; cleanly with SYMBOLICATE.
1127                                    ,(intern (format nil "~:@(FAST-IF-~A~A~)"
1128                                                     tran suffix))
1129                                    ,(intern
1130                                      (format nil "~:@(FAST-CONDITIONAL~A~)"
1131                                              suffix)))
1132                         (:translate ,tran)
1133                         (:conditional ,(if signed
1134                                            cond
1135                                            unsigned))
1136                         (:generator ,cost
1137                                     (inst cmp x
1138                                           ,(if (eq suffix '-c/fixnum)
1139                                                '(fixnumize y)
1140                                                'y)))))
1141                    '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
1142                    '(4 3 6 5 6 5)
1143                    '(t t t t nil nil)))))
1144
1145   (define-conditional-vop < :l :b)
1146   (define-conditional-vop > :g :a))
1147
1148 (define-vop (fast-if-eql/signed fast-conditional/signed)
1149   (:translate eql)
1150   (:generator 6
1151     (inst cmp x y)))
1152
1153 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
1154   (:translate eql)
1155   (:generator 5
1156     (cond ((and (sc-is x signed-reg) (zerop y))
1157            (inst test x x))  ; smaller instruction
1158           (t
1159            (inst cmp x y)))))
1160
1161 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
1162   (:translate eql)
1163   (:generator 6
1164     (inst cmp x y)))
1165
1166 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
1167   (:translate eql)
1168   (:generator 5
1169     (cond ((and (sc-is x unsigned-reg) (zerop y))
1170            (inst test x x))  ; smaller instruction
1171           (t
1172            (inst cmp x y)))))
1173
1174 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
1175 ;;; known fixnum.
1176
1177 ;;; These versions specify a fixnum restriction on their first arg. We have
1178 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
1179 ;;; the first arg and a higher cost. The reason for doing this is to prevent
1180 ;;; fixnum specific operations from being used on word integers, spuriously
1181 ;;; consing the argument.
1182
1183 (define-vop (fast-eql/fixnum fast-conditional)
1184   (:args (x :scs (any-reg)
1185             :load-if (not (and (sc-is x control-stack)
1186                                (sc-is y any-reg))))
1187          (y :scs (any-reg control-stack)))
1188   (:arg-types tagged-num tagged-num)
1189   (:note "inline fixnum comparison")
1190   (:translate eql)
1191   (:generator 4
1192     (inst cmp x y)))
1193 (define-vop (generic-eql/fixnum fast-eql/fixnum)
1194   (:args (x :scs (any-reg descriptor-reg)
1195             :load-if (not (and (sc-is x control-stack)
1196                                (sc-is y any-reg))))
1197          (y :scs (any-reg control-stack)))
1198   (:arg-types * tagged-num)
1199   (:variant-cost 7))
1200
1201 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
1202   (:args (x :scs (any-reg control-stack)))
1203   (:arg-types tagged-num (:constant (signed-byte 30)))
1204   (:info y)
1205   (:translate eql)
1206   (:generator 2
1207     (cond ((and (sc-is x any-reg) (zerop y))
1208            (inst test x x))  ; smaller instruction
1209           (t
1210            (inst cmp x (fixnumize y))))))
1211 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
1212   (:args (x :scs (any-reg descriptor-reg control-stack)))
1213   (:arg-types * (:constant (signed-byte 30)))
1214   (:variant-cost 6))
1215 \f
1216 ;;;; 32-bit logical operations
1217
1218 ;;; Only the lower 5 bits of the shift amount are significant.
1219 (define-vop (shift-towards-someplace)
1220   (:policy :fast-safe)
1221   (:args (num :scs (unsigned-reg) :target r)
1222          (amount :scs (signed-reg) :target ecx))
1223   (:arg-types unsigned-num tagged-num)
1224   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
1225   (:results (r :scs (unsigned-reg) :from (:argument 0)))
1226   (:result-types unsigned-num))
1227
1228 (define-vop (shift-towards-start shift-towards-someplace)
1229   (:translate shift-towards-start)
1230   (:note "SHIFT-TOWARDS-START")
1231   (:generator 1
1232     (move r num)
1233     (move ecx amount)
1234     (inst shr r :cl)))
1235
1236 (define-vop (shift-towards-end shift-towards-someplace)
1237   (:translate shift-towards-end)
1238   (:note "SHIFT-TOWARDS-END")
1239   (:generator 1
1240     (move r num)
1241     (move ecx amount)
1242     (inst shl r :cl)))
1243 \f
1244 ;;;; Modular functions
1245 (defmacro define-mod-binop ((name prototype) function)
1246   `(define-vop (,name ,prototype)
1247        (:args (x :target r :scs (unsigned-reg signed-reg)
1248                  :load-if (not (and (or (sc-is x unsigned-stack)
1249                                         (sc-is x signed-stack))
1250                                     (or (sc-is y unsigned-reg)
1251                                         (sc-is y signed-reg))
1252                                     (or (sc-is r unsigned-stack)
1253                                         (sc-is r signed-stack))
1254                                     (location= x r))))
1255               (y :scs (unsigned-reg signed-reg unsigned-stack signed-stack)))
1256      (:arg-types untagged-num untagged-num)
1257      (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1258                   :load-if (not (and (or (sc-is x unsigned-stack)
1259                                          (sc-is x signed-stack))
1260                                      (or (sc-is y unsigned-reg)
1261                                          (sc-is y unsigned-reg))
1262                                      (or (sc-is r unsigned-stack)
1263                                          (sc-is r unsigned-stack))
1264                                      (location= x r)))))
1265      (:result-types unsigned-num)
1266      (:translate ,function)))
1267 (defmacro define-mod-binop-c ((name prototype) function)
1268   `(define-vop (,name ,prototype)
1269        (:args (x :target r :scs (unsigned-reg signed-reg)
1270                  :load-if (not (and (or (sc-is x unsigned-stack)
1271                                         (sc-is x signed-stack))
1272                                     (or (sc-is r unsigned-stack)
1273                                         (sc-is r signed-stack))
1274                                     (location= x r)))))
1275      (:info y)
1276      (:arg-types untagged-num (:constant (or (unsigned-byte 32) (signed-byte 32))))
1277      (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1278                   :load-if (not (and (or (sc-is x unsigned-stack)
1279                                          (sc-is x signed-stack))
1280                                      (or (sc-is r unsigned-stack)
1281                                          (sc-is r unsigned-stack))
1282                                      (location= x r)))))
1283      (:result-types unsigned-num)
1284      (:translate ,function)))
1285
1286 (macrolet ((def (name -c-p)
1287              (let ((fun32 (intern (format nil "~S-MOD32" name)))
1288                    (vopu (intern (format nil "FAST-~S/UNSIGNED=>UNSIGNED" name)))
1289                    (vopcu (intern (format nil "FAST-~S-C/UNSIGNED=>UNSIGNED" name)))
1290                    (vopf (intern (format nil "FAST-~S/FIXNUM=>FIXNUM" name)))
1291                    (vopcf (intern (format nil "FAST-~S-C/FIXNUM=>FIXNUM" name)))
1292                    (vop32u (intern (format nil "FAST-~S-MOD32/WORD=>UNSIGNED" name)))
1293                    (vop32f (intern (format nil "FAST-~S-MOD32/FIXNUM=>FIXNUM" name)))
1294                    (vop32cu (intern (format nil "FAST-~S-MOD32-C/WORD=>UNSIGNED" name)))
1295                    (vop32cf (intern (format nil "FAST-~S-MOD32-C/FIXNUM=>FIXNUM" name)))
1296                    (sfun30 (intern (format nil "~S-SMOD30" name)))
1297                    (svop30f (intern (format nil "FAST-~S-SMOD30/FIXNUM=>FIXNUM" name)))
1298                    (svop30cf (intern (format nil "FAST-~S-SMOD30-C/FIXNUM=>FIXNUM" name))))
1299                `(progn
1300                   (define-modular-fun ,fun32 (x y) ,name :untagged nil 32)
1301                   (define-modular-fun ,sfun30 (x y) ,name :tagged t 30)
1302                   (define-mod-binop (,vop32u ,vopu) ,fun32)
1303                   (define-vop (,vop32f ,vopf) (:translate ,fun32))
1304                   (define-vop (,svop30f ,vopf) (:translate ,sfun30))
1305                   ,@(when -c-p
1306                       `((define-mod-binop-c (,vop32cu ,vopcu) ,fun32)
1307                         (define-vop (,svop30cf ,vopcf) (:translate ,sfun30))))))))
1308   (def + t)
1309   (def - t)
1310   ;; (no -C variant as x86 MUL instruction doesn't take an immediate)
1311   (def * nil))
1312
1313
1314 (define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
1315              fast-ash-c/unsigned=>unsigned)
1316   (:translate ash-left-mod32))
1317
1318 (define-vop (fast-ash-left-mod32/unsigned=>unsigned
1319              fast-ash-left/unsigned=>unsigned))
1320 (deftransform ash-left-mod32 ((integer count)
1321                               ((unsigned-byte 32) (unsigned-byte 5)))
1322   (when (sb!c::constant-lvar-p count)
1323     (sb!c::give-up-ir1-transform))
1324   '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
1325
1326 (define-vop (fast-ash-left-smod30-c/fixnum=>fixnum
1327              fast-ash-c/fixnum=>fixnum)
1328   (:translate ash-left-smod30))
1329
1330 (define-vop (fast-ash-left-smod30/fixnum=>fixnum
1331              fast-ash-left/fixnum=>fixnum))
1332 (deftransform ash-left-smod30 ((integer count)
1333                                ((signed-byte 30) (unsigned-byte 5)))
1334   (when (sb!c::constant-lvar-p count)
1335     (sb!c::give-up-ir1-transform))
1336   '(%primitive fast-ash-left-smod30/fixnum=>fixnum integer count))
1337
1338 (in-package "SB!C")
1339
1340 (defknown sb!vm::%lea-mod32 (integer integer (member 1 2 4 8) (signed-byte 32))
1341   (unsigned-byte 32)
1342   (foldable flushable movable))
1343 (defknown sb!vm::%lea-smod30 (integer integer (member 1 2 4 8) (signed-byte 32))
1344   (signed-byte 30)
1345   (foldable flushable movable))
1346
1347 (define-modular-fun-optimizer %lea ((base index scale disp) :untagged nil :width width)
1348   (when (and (<= width 32)
1349              (constant-lvar-p scale)
1350              (constant-lvar-p disp))
1351     (cut-to-width base :untagged width nil)
1352     (cut-to-width index :untagged width nil)
1353     'sb!vm::%lea-mod32))
1354 (define-modular-fun-optimizer %lea ((base index scale disp) :tagged t :width width)
1355   (when (and (<= width 30)
1356              (constant-lvar-p scale)
1357              (constant-lvar-p disp))
1358     (cut-to-width base :tagged width t)
1359     (cut-to-width index :tagged width t)
1360     'sb!vm::%lea-smod30))
1361
1362 #+sb-xc-host
1363 (progn
1364   (defun sb!vm::%lea-mod32 (base index scale disp)
1365     (ldb (byte 32 0) (%lea base index scale disp)))
1366   (defun sb!vm::%lea-smod30 (base index scale disp)
1367     (mask-signed-field 30 (%lea base index scale disp))))
1368 #-sb-xc-host
1369 (progn
1370   (defun sb!vm::%lea-mod32 (base index scale disp)
1371     (let ((base (logand base #xffffffff))
1372           (index (logand index #xffffffff)))
1373       ;; can't use modular version of %LEA, as we only have VOPs for
1374       ;; constant SCALE and DISP.
1375       (ldb (byte 32 0) (+ base (* index scale) disp))))
1376   (defun sb!vm::%lea-smod30 (base index scale disp)
1377     (let ((base (mask-signed-field 30 base))
1378           (index (mask-signed-field 30 index)))
1379       ;; can't use modular version of %LEA, as we only have VOPs for
1380       ;; constant SCALE and DISP.
1381       (mask-signed-field 30 (+ base (* index scale) disp)))))
1382
1383 (in-package "SB!VM")
1384
1385 (define-vop (%lea-mod32/unsigned=>unsigned
1386              %lea/unsigned=>unsigned)
1387   (:translate %lea-mod32))
1388 (define-vop (%lea-smod30/fixnum=>fixnum
1389              %lea/fixnum=>fixnum)
1390   (:translate %lea-smod30))
1391
1392 ;;; logical operations
1393 (define-modular-fun lognot-mod32 (x) lognot :untagged nil 32)
1394 (define-vop (lognot-mod32/word=>unsigned)
1395   (:translate lognot-mod32)
1396   (:args (x :scs (unsigned-reg signed-reg unsigned-stack signed-stack) :target r
1397             :load-if (not (and (or (sc-is x unsigned-stack)
1398                                    (sc-is x signed-stack))
1399                                (or (sc-is r unsigned-stack)
1400                                    (sc-is r signed-stack))
1401                                (location= x r)))))
1402   (:arg-types unsigned-num)
1403   (:results (r :scs (unsigned-reg)
1404                :load-if (not (and (or (sc-is x unsigned-stack)
1405                                       (sc-is x signed-stack))
1406                                   (or (sc-is r unsigned-stack)
1407                                       (sc-is r signed-stack))
1408                                   (sc-is r unsigned-stack)
1409                                   (location= x r)))))
1410   (:result-types unsigned-num)
1411   (:policy :fast-safe)
1412   (:generator 1
1413     (move r x)
1414     (inst not r)))
1415
1416 (define-source-transform logeqv (&rest args)
1417   (if (oddp (length args))
1418       `(logxor ,@args)
1419       `(lognot (logxor ,@args))))
1420 (define-source-transform logandc1 (x y)
1421   `(logand (lognot ,x) ,y))
1422 (define-source-transform logandc2 (x y)
1423   `(logand ,x (lognot ,y)))
1424 (define-source-transform logorc1 (x y)
1425   `(logior (lognot ,x) ,y))
1426 (define-source-transform logorc2 (x y)
1427   `(logior ,x (lognot ,y)))
1428 (define-source-transform lognor (x y)
1429   `(lognot (logior ,x ,y)))
1430 (define-source-transform lognand (x y)
1431   `(lognot (logand ,x ,y)))
1432 \f
1433 ;;;; bignum stuff
1434
1435 (define-vop (bignum-length get-header-data)
1436   (:translate sb!bignum:%bignum-length)
1437   (:policy :fast-safe))
1438
1439 (define-vop (bignum-set-length set-header-data)
1440   (:translate sb!bignum:%bignum-set-length)
1441   (:policy :fast-safe))
1442
1443 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
1444   (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
1445 (define-full-reffer+offset bignum-ref-with-offset *
1446   bignum-digits-offset other-pointer-lowtag
1447   (unsigned-reg) unsigned-num sb!bignum:%bignum-ref-with-offset)
1448 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
1449   (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
1450
1451 (define-vop (digit-0-or-plus)
1452   (:translate sb!bignum:%digit-0-or-plusp)
1453   (:policy :fast-safe)
1454   (:args (digit :scs (unsigned-reg)))
1455   (:arg-types unsigned-num)
1456   (:conditional :ns)
1457   (:generator 3
1458     (inst or digit digit)))
1459
1460
1461 ;;; For add and sub with carry the sc of carry argument is any-reg so
1462 ;;; that it may be passed as a fixnum or word and thus may be 0, 1, or
1463 ;;; 4. This is easy to deal with and may save a fixnum-word
1464 ;;; conversion.
1465 (define-vop (add-w/carry)
1466   (:translate sb!bignum:%add-with-carry)
1467   (:policy :fast-safe)
1468   (:args (a :scs (unsigned-reg) :target result)
1469          (b :scs (unsigned-reg unsigned-stack) :to :eval)
1470          (c :scs (any-reg) :target temp))
1471   (:arg-types unsigned-num unsigned-num positive-fixnum)
1472   (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
1473   (:results (result :scs (unsigned-reg) :from (:argument 0))
1474             (carry :scs (unsigned-reg)))
1475   (:result-types unsigned-num positive-fixnum)
1476   (:generator 4
1477     (move result a)
1478     (move temp c)
1479     (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
1480     (inst adc result b)
1481     (inst mov carry 0)
1482     (inst adc carry carry)))
1483
1484 ;;; Note: the borrow is 1 for no borrow and 0 for a borrow, the opposite
1485 ;;; of the x86 convention.
1486 (define-vop (sub-w/borrow)
1487   (:translate sb!bignum:%subtract-with-borrow)
1488   (:policy :fast-safe)
1489   (:args (a :scs (unsigned-reg) :to :eval :target result)
1490          (b :scs (unsigned-reg unsigned-stack) :to :result)
1491          (c :scs (any-reg control-stack)))
1492   (:arg-types unsigned-num unsigned-num positive-fixnum)
1493   (:results (result :scs (unsigned-reg) :from :eval)
1494             (borrow :scs (unsigned-reg)))
1495   (:result-types unsigned-num positive-fixnum)
1496   (:generator 5
1497     (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
1498     (move result a)
1499     (inst sbb result b)
1500     (inst mov borrow 1)
1501     (inst sbb borrow 0)))
1502
1503
1504 (define-vop (bignum-mult-and-add-3-arg)
1505   (:translate sb!bignum:%multiply-and-add)
1506   (:policy :fast-safe)
1507   (:args (x :scs (unsigned-reg) :target eax)
1508          (y :scs (unsigned-reg unsigned-stack))
1509          (carry-in :scs (unsigned-reg unsigned-stack)))
1510   (:arg-types unsigned-num unsigned-num unsigned-num)
1511   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1512                    :to (:result 1) :target lo) eax)
1513   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1514                    :to (:result 0) :target hi) edx)
1515   (:results (hi :scs (unsigned-reg))
1516             (lo :scs (unsigned-reg)))
1517   (:result-types unsigned-num unsigned-num)
1518   (:generator 20
1519     (move eax x)
1520     (inst mul eax y)
1521     (inst add eax carry-in)
1522     (inst adc edx 0)
1523     (move hi edx)
1524     (move lo eax)))
1525
1526 (define-vop (bignum-mult-and-add-4-arg)
1527   (:translate sb!bignum:%multiply-and-add)
1528   (:policy :fast-safe)
1529   (:args (x :scs (unsigned-reg) :target eax)
1530          (y :scs (unsigned-reg unsigned-stack))
1531          (prev :scs (unsigned-reg unsigned-stack))
1532          (carry-in :scs (unsigned-reg unsigned-stack)))
1533   (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1534   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1535                    :to (:result 1) :target lo) eax)
1536   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1537                    :to (:result 0) :target hi) edx)
1538   (:results (hi :scs (unsigned-reg))
1539             (lo :scs (unsigned-reg)))
1540   (:result-types unsigned-num unsigned-num)
1541   (:generator 20
1542     (move eax x)
1543     (inst mul eax y)
1544     (inst add eax prev)
1545     (inst adc edx 0)
1546     (inst add eax carry-in)
1547     (inst adc edx 0)
1548     (move hi edx)
1549     (move lo eax)))
1550
1551
1552 (define-vop (bignum-mult)
1553   (:translate sb!bignum:%multiply)
1554   (:policy :fast-safe)
1555   (:args (x :scs (unsigned-reg) :target eax)
1556          (y :scs (unsigned-reg unsigned-stack)))
1557   (:arg-types unsigned-num unsigned-num)
1558   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1559                    :to (:result 1) :target lo) eax)
1560   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1561                    :to (:result 0) :target hi) edx)
1562   (:results (hi :scs (unsigned-reg))
1563             (lo :scs (unsigned-reg)))
1564   (:result-types unsigned-num unsigned-num)
1565   (:generator 20
1566     (move eax x)
1567     (inst mul eax y)
1568     (move hi edx)
1569     (move lo eax)))
1570
1571 (define-vop (bignum-lognot lognot-mod32/word=>unsigned)
1572   (:translate sb!bignum:%lognot))
1573
1574 (define-vop (fixnum-to-digit)
1575   (:translate sb!bignum:%fixnum-to-digit)
1576   (:policy :fast-safe)
1577   (:args (fixnum :scs (any-reg control-stack) :target digit))
1578   (:arg-types tagged-num)
1579   (:results (digit :scs (unsigned-reg)
1580                    :load-if (not (and (sc-is fixnum control-stack)
1581                                       (sc-is digit unsigned-stack)
1582                                       (location= fixnum digit)))))
1583   (:result-types unsigned-num)
1584   (:generator 1
1585     (move digit fixnum)
1586     (inst sar digit n-fixnum-tag-bits)))
1587
1588 (define-vop (bignum-floor)
1589   (:translate sb!bignum:%floor)
1590   (:policy :fast-safe)
1591   (:args (div-high :scs (unsigned-reg) :target edx)
1592          (div-low :scs (unsigned-reg) :target eax)
1593          (divisor :scs (unsigned-reg unsigned-stack)))
1594   (:arg-types unsigned-num unsigned-num unsigned-num)
1595   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
1596                    :to (:result 0) :target quo) eax)
1597   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
1598                    :to (:result 1) :target rem) edx)
1599   (:results (quo :scs (unsigned-reg))
1600             (rem :scs (unsigned-reg)))
1601   (:result-types unsigned-num unsigned-num)
1602   (:generator 300
1603     (move edx div-high)
1604     (move eax div-low)
1605     (inst div eax divisor)
1606     (move quo eax)
1607     (move rem edx)))
1608
1609 (define-vop (signify-digit)
1610   (:translate sb!bignum:%fixnum-digit-with-correct-sign)
1611   (:policy :fast-safe)
1612   (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
1613   (:arg-types unsigned-num)
1614   (:results (res :scs (any-reg signed-reg)
1615                  :load-if (not (and (sc-is digit unsigned-stack)
1616                                     (sc-is res control-stack signed-stack)
1617                                     (location= digit res)))))
1618   (:result-types signed-num)
1619   (:generator 1
1620     (move res digit)
1621     (when (sc-is res any-reg control-stack)
1622       (inst shl res n-fixnum-tag-bits))))
1623
1624 (define-vop (digit-ashr)
1625   (:translate sb!bignum:%ashr)
1626   (:policy :fast-safe)
1627   (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
1628          (count :scs (unsigned-reg) :target ecx))
1629   (:arg-types unsigned-num positive-fixnum)
1630   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
1631   (:results (result :scs (unsigned-reg) :from (:argument 0)
1632                     :load-if (not (and (sc-is result unsigned-stack)
1633                                        (location= digit result)))))
1634   (:result-types unsigned-num)
1635   (:generator 2
1636     (move result digit)
1637     (move ecx count)
1638     (inst sar result :cl)))
1639
1640 (define-vop (digit-ashr/c)
1641   (:translate sb!bignum:%ashr)
1642   (:policy :fast-safe)
1643   (:args (digit :scs (unsigned-reg unsigned-stack) :target result))
1644   (:arg-types unsigned-num (:constant (integer 0 31)))
1645   (:info count)
1646   (:results (result :scs (unsigned-reg) :from (:argument 0)
1647                     :load-if (not (and (sc-is result unsigned-stack)
1648                                        (location= digit result)))))
1649   (:result-types unsigned-num)
1650   (:generator 1
1651     (move result digit)
1652     (inst sar result count)))
1653
1654 (define-vop (digit-lshr digit-ashr)
1655   (:translate sb!bignum:%digit-logical-shift-right)
1656   (:generator 1
1657     (move result digit)
1658     (move ecx count)
1659     (inst shr result :cl)))
1660
1661 (define-vop (digit-ashl digit-ashr)
1662   (:translate sb!bignum:%ashl)
1663   (:generator 1
1664     (move result digit)
1665     (move ecx count)
1666     (inst shl result :cl)))
1667 \f
1668 ;;;; static functions
1669
1670 (define-static-fun two-arg-/ (x y) :translate /)
1671
1672 (define-static-fun two-arg-gcd (x y) :translate gcd)
1673 (define-static-fun two-arg-lcm (x y) :translate lcm)
1674
1675 (define-static-fun two-arg-and (x y) :translate logand)
1676 (define-static-fun two-arg-ior (x y) :translate logior)
1677 (define-static-fun two-arg-xor (x y) :translate logxor)
1678
1679 \f
1680 ;;; Support for the Mersenne Twister, MT19937, random number generator
1681 ;;; due to Matsumoto and Nishimura.
1682 ;;;
1683 ;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A
1684 ;;; 623-dimensionally equidistributed uniform pseudorandom number
1685 ;;; generator.", ACM Transactions on Modeling and Computer Simulation,
1686 ;;; 1997, to appear.
1687 ;;;
1688 ;;; State:
1689 ;;;  0-1:   Constant matrix A. [0, #x9908b0df] (not used here)
1690 ;;;  2:     Index; init. to 1.
1691 ;;;  3-626: State.
1692 (defknown random-mt19937 ((simple-array (unsigned-byte 32) (*)))
1693   (unsigned-byte 32) ())
1694 (define-vop (random-mt19937)
1695   (:policy :fast-safe)
1696   (:translate random-mt19937)
1697   (:args (state :scs (descriptor-reg) :to :result))
1698   (:arg-types simple-array-unsigned-byte-32)
1699   (:temporary (:sc unsigned-reg :from (:eval 0) :to :result) k)
1700   (:temporary (:sc unsigned-reg :offset eax-offset
1701                    :from (:eval 0) :to :result) tmp)
1702   (:results (y :scs (unsigned-reg) :from (:eval 0)))
1703   (:result-types unsigned-num)
1704   (:generator 50
1705     (loadw k state (+ 2 vector-data-offset) other-pointer-lowtag)
1706     (inst cmp k 624)
1707     (inst jmp :ne no-update)
1708     (inst mov tmp state)        ; The state is passed in EAX.
1709     (inst call (make-fixup 'random-mt19937-update :assembly-routine))
1710     ;; Restore k, and set to 0.
1711     (inst xor k k)
1712     NO-UPDATE
1713     ;; y = ptgfsr[k++];
1714     (inst mov y (make-ea-for-vector-data state :index k :offset 3))
1715     ;; y ^= (y >> 11);
1716     (inst shr y 11)
1717     (inst xor y (make-ea-for-vector-data state :index k :offset 3))
1718     ;; y ^= (y << 7) & #x9d2c5680
1719     (inst mov tmp y)
1720     (inst inc k)
1721     (inst shl tmp 7)
1722     (storew k state (+ 2 vector-data-offset) other-pointer-lowtag)
1723     (inst and tmp #x9d2c5680)
1724     (inst xor y tmp)
1725     ;; y ^= (y << 15) & #xefc60000
1726     (inst mov tmp y)
1727     (inst shl tmp 15)
1728     (inst and tmp #xefc60000)
1729     (inst xor y tmp)
1730     ;; y ^= (y >> 18);
1731     (inst mov tmp y)
1732     (inst shr tmp 18)
1733     (inst xor y tmp)))
1734
1735 (in-package "SB!C")
1736
1737 (defun mask-result (class width result)
1738   (ecase class
1739     (:unsigned
1740      `(logand ,result ,(1- (ash 1 width))))
1741     (:signed
1742      `(mask-signed-field ,width ,result))))
1743
1744 ;;; This is essentially a straight implementation of the algorithm in
1745 ;;; "Strength Reduction of Multiplications by Integer Constants",
1746 ;;; Youfeng Wu, ACM SIGPLAN Notices, Vol. 30, No.2, February 1995.
1747 (defun basic-decompose-multiplication (class width arg num n-bits condensed)
1748   (case (aref condensed 0)
1749     (0
1750      (let ((tmp (min 3 (aref condensed 1))))
1751        (decf (aref condensed 1) tmp)
1752        (mask-result class width
1753                     `(%lea ,arg
1754                            ,(decompose-multiplication class width
1755                              arg (ash (1- num) (- tmp)) (1- n-bits) (subseq condensed 1))
1756                            ,(ash 1 tmp) 0))))
1757     ((1 2 3)
1758      (let ((r0 (aref condensed 0)))
1759        (incf (aref condensed 1) r0)
1760        (mask-result class width
1761                     `(%lea ,(decompose-multiplication class width
1762                              arg (- num (ash 1 r0)) (1- n-bits) (subseq condensed 1))
1763                            ,arg
1764                            ,(ash 1 r0) 0))))
1765     (t (let ((r0 (aref condensed 0)))
1766          (setf (aref condensed 0) 0)
1767          (mask-result class width
1768                       `(ash ,(decompose-multiplication class width
1769                               arg (ash num (- r0)) n-bits condensed)
1770                             ,r0))))))
1771
1772 (defun decompose-multiplication (class width arg num n-bits condensed)
1773   (cond
1774     ((= n-bits 0) 0)
1775     ((= num 1) arg)
1776     ((= n-bits 1)
1777      (mask-result class width `(ash ,arg ,(1- (integer-length num)))))
1778     ((let ((max 0) (end 0))
1779        (loop for i from 2 to (length condensed)
1780              for j = (reduce #'+ (subseq condensed 0 i))
1781              when (and (> (- (* 2 i) 3 j) max)
1782                        (< (+ (ash 1 (1+ j))
1783                              (ash (ldb (byte (- 32 (1+ j)) (1+ j)) num)
1784                                   (1+ j)))
1785                           (ash 1 32)))
1786                do (setq max (- (* 2 i) 3 j)
1787                         end i))
1788        (when (> max 0)
1789          (let ((j (reduce #'+ (subseq condensed 0 end))))
1790            (let ((n2 (+ (ash 1 (1+ j))
1791                         (ash (ldb (byte (- 32 (1+ j)) (1+ j)) num) (1+ j))))
1792                  (n1 (1+ (ldb (byte (1+ j) 0) (lognot num)))))
1793            (mask-result class width
1794                         `(- ,(optimize-multiply class width arg n2)
1795                             ,(optimize-multiply  class width arg n1))))))))
1796     ((dolist (i '(9 5 3))
1797        (when (integerp (/ num i))
1798          (when (< (logcount (/ num i)) (logcount num))
1799            (let ((x (gensym)))
1800              (return `(let ((,x ,(optimize-multiply class width arg (/ num i))))
1801                        ,(mask-result class width
1802                                      `(%lea ,x ,x (1- ,i) 0)))))))))
1803     (t (basic-decompose-multiplication class width arg num n-bits condensed))))
1804
1805 (defun optimize-multiply (class width arg x)
1806   (let* ((n-bits (logcount x))
1807          (condensed (make-array n-bits)))
1808     (let ((count 0) (bit 0))
1809       (dotimes (i 32)
1810         (cond ((logbitp i x)
1811                (setf (aref condensed bit) count)
1812                (setf count 1)
1813                (incf bit))
1814               (t (incf count)))))
1815     (decompose-multiplication class width arg x n-bits condensed)))
1816
1817 (defun *-transformer (class width y)
1818   (cond
1819     ((= y (ash 1 (integer-length y)))
1820      ;; there's a generic transform for y = 2^k
1821      (give-up-ir1-transform))
1822     ((member y '(3 5 9))
1823      ;; we can do these multiplications directly using LEA
1824      `(%lea x x ,(1- y) 0))
1825     ((member :pentium4 *backend-subfeatures*)
1826      ;; the pentium4's multiply unit is reportedly very good
1827      (give-up-ir1-transform))
1828     ;; FIXME: should make this more fine-grained.  If nothing else,
1829     ;; there should probably be a cutoff of about 9 instructions on
1830     ;; pentium-class machines.
1831     (t (optimize-multiply class width 'x y))))
1832
1833 (deftransform * ((x y)
1834                  ((unsigned-byte 32) (constant-arg (unsigned-byte 32)))
1835                  (unsigned-byte 32))
1836   "recode as leas, shifts and adds"
1837   (let ((y (lvar-value y)))
1838     (*-transformer :unsigned 32 y)))
1839 (deftransform sb!vm::*-mod32
1840     ((x y) ((unsigned-byte 32) (constant-arg (unsigned-byte 32)))
1841      (unsigned-byte 32))
1842   "recode as leas, shifts and adds"
1843   (let ((y (lvar-value y)))
1844     (*-transformer :unsigned 32 y)))
1845
1846 (deftransform * ((x y)
1847                  ((signed-byte 30) (constant-arg (unsigned-byte 32)))
1848                  (signed-byte 30))
1849   "recode as leas, shifts and adds"
1850   (let ((y (lvar-value y)))
1851     (*-transformer :signed 30 y)))
1852 (deftransform sb!vm::*-smod30
1853     ((x y) ((signed-byte 30) (constant-arg (unsigned-byte 32)))
1854      (signed-byte 30))
1855   "recode as leas, shifts and adds"
1856   (let ((y (lvar-value y)))
1857     (*-transformer :signed 30 y)))
1858
1859 ;;; FIXME: we should also be able to write an optimizer or two to
1860 ;;; convert (+ (* x 2) 17), (- (* x 9) 5) to a %LEA.