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