src/assembly/x86/arith.lisp

   1 ;;;; simple cases for generic arithmetic
   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 ;;;; addition, subtraction, and multiplication
  15
  16 (macrolet ((define-generic-arith-routine ((fun cost) &body body)
  17              `(define-assembly-routine (,(symbolicate "GENERIC-" fun)
  18                                         (:cost ,cost)
  19                                         (:return-style :full-call)
  20                                         (:translate ,fun)
  21                                         (:policy :safe)
  22                                         (:save-p t))
  23                 ((:arg x (descriptor-reg any-reg) edx-offset)
  24                  (:arg y (descriptor-reg any-reg)
  25                        ;; this seems wrong esi-offset -- FIXME: What's it mean?
  26                        edi-offset)
  27
  28                  (:res res (descriptor-reg any-reg) edx-offset)
  29
  30                  (:temp eax unsigned-reg eax-offset)
  31                  (:temp ecx unsigned-reg ecx-offset))
  32
  33                 (inst mov ecx x)
  34                 (inst or ecx y)
  35                 (inst test ecx fixnum-tag-mask)  ; both fixnums?
  36                 (inst jmp :nz DO-STATIC-FUN)     ; no - do generic
  37
  38                 ,@body
  39                 (inst clc) ; single-value return
  40                 (inst ret)
  41
  42                 DO-STATIC-FUN
  43                 (inst pop eax)
  44                 (inst push ebp-tn)
  45                 (inst lea
  46                       ebp-tn
  47                       (make-ea :dword :base esp-tn :disp n-word-bytes))
  48                 (inst sub esp-tn (fixnumize 2))
  49                 (inst push eax)  ; callers return addr
  50                 (inst mov ecx (fixnumize 2)) ; arg count
  51                 (inst jmp
  52                       (make-ea :dword
  53                                :disp (+ nil-value
  54                                         (static-fun-offset
  55                                          ',(symbolicate "TWO-ARG-" fun))))))))
  56
  57   (define-generic-arith-routine (+ 10)
  58     (move res x)
  59     (inst add res y)
  60     (inst jmp :no OKAY)
  61     (inst rcr res 1)                  ; carry has correct sign
  62     (inst sar res 1)                  ; remove type bits
  63
  64     (move ecx res)
  65
  66     (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
  67       (storew ecx res bignum-digits-offset other-pointer-lowtag))
  68
  69     OKAY)
  70
  71   (define-generic-arith-routine (- 10)
  72     (move res x)
  73     (inst sub res y)
  74     (inst jmp :no OKAY)
  75     (inst cmc)                        ; carry has correct sign now
  76     (inst rcr res 1)
  77     (inst sar res 1)                  ; remove type bits
  78
  79     (move ecx res)
  80
  81     (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
  82       (storew ecx res bignum-digits-offset other-pointer-lowtag))
  83     OKAY)
  84
  85   (define-generic-arith-routine (* 30)
  86     (move eax x)                          ; must use eax for 64-bit result
  87     (inst sar eax n-fixnum-tag-bits)      ; remove *4 fixnum bias
  88     (inst imul y)                         ; result in edx:eax
  89     (inst jmp :no okay)                   ; still fixnum
  90
  91     ;; zzz jrd changed edx to ebx in here, as edx isn't listed as a temp, above
  92     ;;     pfw says that loses big -- edx is target for arg x and result res
  93     ;;     note that 'edx' is not defined -- using x
  94     (inst shrd eax x n-fixnum-tag-bits)    ; high bits from edx
  95     (inst sar x n-fixnum-tag-bits)         ; now shift edx too
  96
  97     (move ecx x)                           ; save high bits from cdq
  98     (inst cdq)                             ; edx:eax <- sign-extend of eax
  99     (inst cmp x ecx)
 100     (inst jmp :e SINGLE-WORD-BIGNUM)
 101
 102     (with-fixed-allocation (res bignum-widetag (+ bignum-digits-offset 2))
 103       (storew eax res bignum-digits-offset other-pointer-lowtag)
 104       (storew ecx res (1+ bignum-digits-offset) other-pointer-lowtag))
 105     (inst jmp DONE)
 106
 107     SINGLE-WORD-BIGNUM
 108
 109     (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
 110       (storew eax res bignum-digits-offset other-pointer-lowtag))
 111     (inst jmp DONE)
 112
 113     OKAY
 114     (move res eax)
 115     DONE))
 116 \f
 117 ;;;; negation
 118
 119 (define-assembly-routine (generic-negate
 120                           (:cost 10)
 121                           (:return-style :full-call)
 122                           (:policy :safe)
 123                           (:translate %negate)
 124                           (:save-p t))
 125                          ((:arg x (descriptor-reg any-reg) edx-offset)
 126                           (:res res (descriptor-reg any-reg) edx-offset)
 127
 128                           (:temp eax unsigned-reg eax-offset)
 129                           (:temp ecx unsigned-reg ecx-offset))
 130   (inst test x fixnum-tag-mask)
 131   (inst jmp :z FIXNUM)
 132
 133   (inst pop eax)
 134   (inst push ebp-tn)
 135   (inst lea ebp-tn (make-ea :dword :base esp-tn :disp n-word-bytes))
 136   (inst sub esp-tn (fixnumize 2))
 137   (inst push eax)
 138   (inst mov ecx (fixnumize 1))    ; arg count
 139   (inst jmp (make-ea :dword
 140                      :disp (+ nil-value (static-fun-offset '%negate))))
 141
 142   FIXNUM
 143   (move res x)
 144   (inst neg res)                        ; (- most-negative-fixnum) is BIGNUM
 145   (inst jmp :no OKAY)
 146   (inst shr res n-fixnum-tag-bits)      ; sign bit is data - remove type bits
 147   (move ecx res)
 148
 149   (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
 150     (storew ecx res bignum-digits-offset other-pointer-lowtag))
 151
 152   OKAY)
 153 \f
 154 ;;;; comparison
 155
 156 (macrolet ((define-cond-assem-rtn (name translate static-fn test)
 157              #+sb-assembling
 158              `(define-assembly-routine (,name
 159                                         (:return-style :none))
 160                 ((:arg x (descriptor-reg any-reg) edx-offset)
 161                  (:arg y (descriptor-reg any-reg) edi-offset)
 162
 163                  (:temp ecx unsigned-reg ecx-offset))
 164
 165                 (inst mov ecx x)
 166                 (inst or ecx y)
 167                 (inst test ecx fixnum-tag-mask)
 168                 (inst jmp :nz DO-STATIC-FUN)  ; are both fixnums?
 169
 170                 (inst cmp x y)
 171                 (inst ret)
 172
 173                 DO-STATIC-FUN
 174                 (move ecx esp-tn)
 175                 (inst sub esp-tn (fixnumize 3))
 176                 (inst mov (make-ea :dword
 177                                    :base ecx :disp (fixnumize -1))
 178                       ebp-tn)
 179                 (move ebp-tn ecx)
 180                 (inst mov ecx (fixnumize 2))
 181                 (inst call (make-ea :dword
 182                                     :disp (+ nil-value
 183                                              (static-fun-offset ',static-fn))))
 184                 ;; HACK: We depend on NIL having the lowest address of all
 185                 ;; static symbols (including T)
 186                 ,@(ecase test
 187                     (:l `((inst mov y (1+ nil-value))
 188                           (inst cmp y x)))
 189                     (:g `((inst cmp x (1+ nil-value)))))
 190                 (inst ret))
 191              #-sb-assembling
 192                           `(define-vop (,name)
 193                 (:translate ,translate)
 194                 (:policy :safe)
 195                 (:save-p t)
 196                 (:args (x :scs (descriptor-reg any-reg) :target edx)
 197                        (y :scs (descriptor-reg any-reg) :target edi))
 198
 199                 (:temporary (:sc unsigned-reg :offset edx-offset
 200                                  :from (:argument 0))
 201                             edx)
 202                 (:temporary (:sc unsigned-reg :offset edi-offset
 203                                  :from (:argument 1))
 204                             edi)
 205
 206                 (:temporary (:sc unsigned-reg :offset ecx-offset
 207                                  :from :eval)
 208                             ecx)
 209                 (:conditional ,test)
 210                 (:generator 10
 211                    (move edx x)
 212                    (move edi y)
 213                    (inst lea ecx (make-ea :dword
 214                                           :disp (make-fixup ',name :assembly-routine)))
 215                    (inst call ecx)))))
 216
 217   (define-cond-assem-rtn generic-< < two-arg-< :l)
 218   (define-cond-assem-rtn generic-> > two-arg-> :g))
 219
 220 #+sb-assembling
 221 (define-assembly-routine (generic-eql
 222                           (:return-style :none))
 223                          ((:arg x (descriptor-reg any-reg) edx-offset)
 224                           (:arg y (descriptor-reg any-reg) edi-offset)
 225
 226                           (:temp ecx unsigned-reg ecx-offset))
 227   (inst mov ecx x)
 228   (inst and ecx y)
 229   (inst and ecx lowtag-mask)
 230   (inst cmp ecx other-pointer-lowtag)
 231   (inst jmp :e DO-STATIC-FUN)
 232
 233   ;; Not both other pointers
 234   (inst cmp x y)
 235   RET
 236   (inst ret)
 237
 238   DO-STATIC-FUN
 239   ;; Might as well fast path that...
 240   (inst cmp x y)
 241   (inst jmp :e RET)
 242
 243   (move ecx esp-tn)
 244   (inst sub esp-tn (fixnumize 3))
 245   (inst mov (make-ea :dword
 246                      :base ecx
 247                      :disp (fixnumize -1))
 248         ebp-tn)
 249   (move ebp-tn ecx)
 250   (inst mov ecx (fixnumize 2))
 251   (inst call (make-ea :dword
 252                       :disp (+ nil-value (static-fun-offset 'eql))))
 253   (load-symbol y t)
 254   (inst cmp x y)
 255   (inst ret))
 256
 257 #-sb-assembling
 258 (define-vop (generic-eql)
 259   (:translate eql)
 260   (:policy :safe)
 261   (:save-p t)
 262   (:args (x :scs (descriptor-reg any-reg) :target edx)
 263          (y :scs (descriptor-reg any-reg) :target edi))
 264
 265   (:temporary (:sc unsigned-reg :offset edx-offset
 266                :from (:argument 0))
 267               edx)
 268   (:temporary (:sc unsigned-reg :offset edi-offset
 269                :from (:argument 1))
 270               edi)
 271
 272   (:temporary (:sc unsigned-reg :offset ecx-offset
 273                :from :eval)
 274               ecx)
 275   (:conditional :e)
 276   (:generator 10
 277     (move edx x)
 278     (move edi y)
 279     (inst lea ecx (make-ea :dword
 280                            :disp (make-fixup 'generic-eql :assembly-routine)))
 281     (inst call ecx)))
 282
 283 #+sb-assembling
 284 (define-assembly-routine (generic-=
 285                           (:return-style :none))
 286                          ((:arg x (descriptor-reg any-reg) edx-offset)
 287                           (:arg y (descriptor-reg any-reg) edi-offset)
 288
 289                           (:temp ecx unsigned-reg ecx-offset))
 290   (inst mov ecx x)
 291   (inst or ecx y)
 292   (inst test ecx fixnum-tag-mask)
 293   (inst jmp :nz DO-STATIC-FUN)
 294
 295   ;; Both fixnums
 296   (inst cmp x y)
 297   (inst ret)
 298
 299   DO-STATIC-FUN
 300   (move ecx esp-tn)
 301   (inst sub esp-tn (fixnumize 3))
 302   (inst mov (make-ea :dword
 303                      :base ecx
 304                      :disp (fixnumize -1))
 305         ebp-tn)
 306   (move ebp-tn ecx)
 307   (inst mov ecx (fixnumize 2))
 308   (inst call (make-ea :dword
 309                       :disp (+ nil-value (static-fun-offset 'two-arg-=))))
 310   (load-symbol y t)
 311   (inst cmp x y)
 312   (inst ret))
 313
 314 #-sb-assembling
 315 (define-vop (generic-=)
 316   (:translate =)
 317   (:policy :safe)
 318   (:save-p t)
 319   (:args (x :scs (descriptor-reg any-reg) :target edx)
 320          (y :scs (descriptor-reg any-reg) :target edi))
 321
 322   (:temporary (:sc unsigned-reg :offset edx-offset
 323                :from (:argument 0))
 324               edx)
 325   (:temporary (:sc unsigned-reg :offset edi-offset
 326                :from (:argument 1))
 327               edi)
 328
 329   (:temporary (:sc unsigned-reg :offset ecx-offset
 330                :from :eval)
 331               ecx)
 332   (:conditional :e)
 333   (:generator 10
 334     (move edx x)
 335     (move edi y)
 336     (inst lea ecx (make-ea :dword
 337                            :disp (make-fixup 'generic-= :assembly-routine)))
 338     (inst call ecx)))
 339
 340 \f
 341 ;;; Support for the Mersenne Twister, MT19937, random number generator
 342 ;;; due to Matsumoto and Nishimura.
 343 ;;;
 344 ;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A
 345 ;;; 623-dimensionally equidistributed uniform pseudorandom number
 346 ;;; generator.", ACM Transactions on Modeling and Computer Simulation,
 347 ;;; 1997, to appear.
 348 ;;;
 349 ;;; State:
 350 ;;;  0-1:   Constant matrix A. [0, #x9908b0df] (not used here)
 351 ;;;  2:     Index; init. to 1.
 352 ;;;  3-626: State.
 353
 354 ;;; This assembly routine is called from the inline VOP and updates
 355 ;;; the state vector with new random numbers. The state vector is
 356 ;;; passed in the EAX register.
 357 #+sb-assembling ; We don't want a vop for this one.
 358 (define-assembly-routine
 359     (random-mt19937-update)
 360     ((:temp state unsigned-reg eax-offset)
 361      (:temp k unsigned-reg ebx-offset)
 362      (:temp y unsigned-reg ecx-offset)
 363      (:temp tmp unsigned-reg edx-offset))
 364
 365   ;; Save the temporary registers.
 366   (inst push k)
 367   (inst push y)
 368   (inst push tmp)
 369
 370   ;; Generate a new set of results.
 371   (inst xor k k)
 372   LOOP1
 373   (inst mov y (make-ea-for-vector-data state :index k :offset 3))
 374   (inst mov tmp (make-ea-for-vector-data state :index k :offset (+ 1 3)))
 375   (inst and y #x80000000)
 376   (inst and tmp #x7fffffff)
 377   (inst or y tmp)
 378   (inst shr y 1)
 379   (inst jmp :nc skip1)
 380   (inst xor y #x9908b0df)
 381   SKIP1
 382   (inst xor y (make-ea-for-vector-data state :index k :offset (+ 397 3)))
 383   (inst mov (make-ea-for-vector-data state :index k :offset 3) y)
 384   (inst inc k)
 385   (inst cmp k (- 624 397))
 386   (inst jmp :b loop1)
 387   LOOP2
 388   (inst mov y (make-ea-for-vector-data state :index k :offset 3))
 389   (inst mov tmp (make-ea-for-vector-data state :index k :offset (+ 1 3)))
 390   (inst and y #x80000000)
 391   (inst and tmp #x7fffffff)
 392   (inst or y tmp)
 393   (inst shr y 1)
 394   (inst jmp :nc skip2)
 395   (inst xor y #x9908b0df)
 396   SKIP2
 397   (inst xor y (make-ea-for-vector-data state :index k :offset (+ (- 397 624) 3)))
 398   (inst mov (make-ea-for-vector-data state :index k :offset 3) y)
 399   (inst inc k)
 400   (inst cmp k (- 624 1))
 401   (inst jmp :b loop2)
 402
 403   (inst mov y (make-ea-for-vector-data state :offset (+ (- 624 1) 3)))
 404   (inst mov tmp (make-ea-for-vector-data state :offset (+ 0 3)))
 405   (inst and y #x80000000)
 406   (inst and tmp #x7fffffff)
 407   (inst or y tmp)
 408   (inst shr y 1)
 409   (inst jmp :nc skip3)
 410   (inst xor y #x9908b0df)
 411   SKIP3
 412   (inst xor y (make-ea-for-vector-data state :offset (+ (- 397 1) 3)))
 413   (inst mov (make-ea-for-vector-data state :offset (+ (- 624 1) 3)) y)
 414
 415   ;; Restore the temporary registers and return.
 416   (inst pop tmp)
 417   (inst pop y)
 418   (inst pop k)
 419   (inst ret))