1 ;;;; simple cases for generic arithmetic
3 ;;;; This software is part of the SBCL system. See the README file for
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.
14 ;;;; addition, subtraction, and multiplication
16 (macrolet ((define-generic-arith-routine ((fun cost) &body body)
17 `(define-assembly-routine (,(symbolicate "GENERIC-" fun)
19 (:return-style :full-call)
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?
28 (:res res (descriptor-reg any-reg) edx-offset)
30 (:temp eax unsigned-reg eax-offset)
31 (:temp ecx unsigned-reg ecx-offset))
35 (inst test ecx fixnum-tag-mask) ; both fixnums?
36 (inst jmp :nz DO-STATIC-FUN) ; no - do generic
39 (inst clc) ; single-value return
43 ;; Same as: (inst enter (fixnumize 1))
45 (inst mov ebp-tn esp-tn)
46 (inst sub esp-tn (fixnumize 1))
47 (inst push (make-ea :dword :base ebp-tn
48 :disp (frame-byte-offset return-pc-save-offset)))
49 (inst mov ecx (fixnumize 2)) ; arg count
54 ',(symbolicate "TWO-ARG-" fun))))))))
56 (define-generic-arith-routine (+ 10)
60 (inst rcr res 1) ; carry has correct sign
61 (inst sar res 1) ; remove type bits
65 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
66 (storew ecx res bignum-digits-offset other-pointer-lowtag))
70 (define-generic-arith-routine (- 10)
74 (inst cmc) ; carry has correct sign now
76 (inst sar res 1) ; remove type bits
80 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
81 (storew ecx res bignum-digits-offset other-pointer-lowtag))
84 (define-generic-arith-routine (* 30)
85 (move eax x) ; must use eax for 64-bit result
86 (inst sar eax n-fixnum-tag-bits) ; remove *4 fixnum bias
87 (inst imul y) ; result in edx:eax
88 (inst jmp :no OKAY) ; still fixnum
90 ;; zzz jrd changed edx to ebx in here, as edx isn't listed as a temp, above
91 ;; pfw says that loses big -- edx is target for arg x and result res
92 ;; note that 'edx' is not defined -- using x
93 (inst shrd eax x n-fixnum-tag-bits) ; high bits from edx
94 (inst sar x n-fixnum-tag-bits) ; now shift edx too
96 (move ecx x) ; save high bits from cdq
97 (inst cdq) ; edx:eax <- sign-extend of eax
99 (inst jmp :e SINGLE-WORD-BIGNUM)
101 (with-fixed-allocation (res bignum-widetag (+ bignum-digits-offset 2))
102 (storew eax res bignum-digits-offset other-pointer-lowtag)
103 (storew ecx res (1+ bignum-digits-offset) other-pointer-lowtag))
108 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
109 (storew eax res bignum-digits-offset other-pointer-lowtag))
118 (define-assembly-routine (generic-negate
120 (:return-style :full-call)
124 ((:arg x (descriptor-reg any-reg) edx-offset)
125 (:res res (descriptor-reg any-reg) edx-offset)
127 (:temp eax unsigned-reg eax-offset)
128 (:temp ecx unsigned-reg ecx-offset))
129 (inst test x fixnum-tag-mask)
133 (inst mov ebp-tn esp-tn)
134 (inst sub esp-tn (fixnumize 1))
135 (inst push (make-ea :dword :base ebp-tn
136 :disp (frame-byte-offset return-pc-save-offset)))
137 (inst mov ecx (fixnumize 1)) ; arg count
138 (inst jmp (make-ea :dword
139 :disp (+ nil-value (static-fun-offset '%negate))))
143 (inst neg res) ; (- most-negative-fixnum) is BIGNUM
145 (inst shr res n-fixnum-tag-bits) ; sign bit is data - remove type bits
148 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
149 (storew ecx res bignum-digits-offset other-pointer-lowtag))
155 (macrolet ((define-cond-assem-rtn (name translate static-fn test)
157 `(define-assembly-routine (,name
158 (:return-style :none))
159 ((:arg x (descriptor-reg any-reg) edx-offset)
160 (:arg y (descriptor-reg any-reg) edi-offset)
162 (:temp ecx unsigned-reg ecx-offset))
166 (inst test ecx fixnum-tag-mask)
167 (inst jmp :nz DO-STATIC-FUN) ; are both fixnums?
173 (inst sub esp-tn (fixnumize 3))
174 (inst mov (make-ea :dword :base esp-tn
175 :disp (frame-byte-offset
180 (inst lea ebp-tn (make-ea :dword :base esp-tn
181 :disp (frame-byte-offset
185 (inst mov ecx (fixnumize 2))
186 (inst call (make-ea :dword
188 (static-fun-offset ',static-fn))))
189 ;; HACK: We depend on NIL having the lowest address of all
190 ;; static symbols (including T)
192 (:l `((inst mov y (1+ nil-value))
194 (:g `((inst cmp x (1+ nil-value)))))
198 (:translate ,translate)
201 (:args (x :scs (descriptor-reg any-reg) :target edx)
202 (y :scs (descriptor-reg any-reg) :target edi))
204 (:temporary (:sc unsigned-reg :offset edx-offset
207 (:temporary (:sc unsigned-reg :offset edi-offset
211 (:temporary (:sc unsigned-reg :offset ecx-offset
218 (inst lea ecx (make-ea :dword
219 :disp (make-fixup ',name :assembly-routine)))
222 (define-cond-assem-rtn generic-< < two-arg-< :l)
223 (define-cond-assem-rtn generic-> > two-arg-> :g))
226 (define-assembly-routine (generic-eql
227 (:return-style :none))
228 ((:arg x (descriptor-reg any-reg) edx-offset)
229 (:arg y (descriptor-reg any-reg) edi-offset)
231 (:temp ecx unsigned-reg ecx-offset))
234 (inst and ecx lowtag-mask)
235 (inst cmp ecx other-pointer-lowtag)
236 (inst jmp :e DO-STATIC-FUN)
238 ;; At least one fixnum
244 ;; Might as well fast path that...
248 (inst sub esp-tn (fixnumize 3))
249 (inst mov (make-ea :dword :base esp-tn
250 :disp (frame-byte-offset
255 (inst lea ebp-tn (make-ea :dword :base esp-tn
256 :disp (frame-byte-offset
260 (inst mov ecx (fixnumize 2))
261 (inst call (make-ea :dword
262 :disp (+ nil-value (static-fun-offset 'eql))))
268 (define-vop (generic-eql)
272 (:args (x :scs (descriptor-reg any-reg) :target edx)
273 (y :scs (descriptor-reg any-reg) :target edi))
275 (:temporary (:sc unsigned-reg :offset edx-offset
278 (:temporary (:sc unsigned-reg :offset edi-offset
282 (:temporary (:sc unsigned-reg :offset ecx-offset
289 (inst lea ecx (make-ea :dword
290 :disp (make-fixup 'generic-eql :assembly-routine)))
294 (define-assembly-routine (generic-=
295 (:return-style :none))
296 ((:arg x (descriptor-reg any-reg) edx-offset)
297 (:arg y (descriptor-reg any-reg) edi-offset)
299 (:temp ecx unsigned-reg ecx-offset))
302 (inst test ecx fixnum-tag-mask)
303 (inst jmp :nz DO-STATIC-FUN)
310 (inst sub esp-tn (fixnumize 3))
311 (inst mov (make-ea :dword :base esp-tn
312 :disp (frame-byte-offset
317 (inst lea ebp-tn (make-ea :dword :base esp-tn
318 :disp (frame-byte-offset
322 (inst mov ecx (fixnumize 2))
323 (inst call (make-ea :dword
324 :disp (+ nil-value (static-fun-offset 'two-arg-=))))
330 (define-vop (generic-=)
334 (:args (x :scs (descriptor-reg any-reg) :target edx)
335 (y :scs (descriptor-reg any-reg) :target edi))
337 (:temporary (:sc unsigned-reg :offset edx-offset
340 (:temporary (:sc unsigned-reg :offset edi-offset
344 (:temporary (:sc unsigned-reg :offset ecx-offset
351 (inst lea ecx (make-ea :dword
352 :disp (make-fixup 'generic-= :assembly-routine)))
356 ;;; Support for the Mersenne Twister, MT19937, random number generator
357 ;;; due to Matsumoto and Nishimura.
359 ;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A
360 ;;; 623-dimensionally equidistributed uniform pseudorandom number
361 ;;; generator.", ACM Transactions on Modeling and Computer Simulation,
365 ;;; 0-1: Constant matrix A. [0, #x9908b0df] (not used here)
366 ;;; 2: Index; init. to 1.
369 ;;; This assembly routine is called from the inline VOP and updates
370 ;;; the state vector with new random numbers. The state vector is
371 ;;; passed in the EAX register.
372 #+sb-assembling ; We don't want a vop for this one.
373 (define-assembly-routine
374 (random-mt19937-update)
375 ((:temp state unsigned-reg eax-offset)
376 (:temp k unsigned-reg ebx-offset)
377 (:temp y unsigned-reg ecx-offset)
378 (:temp tmp unsigned-reg edx-offset))
380 ;; Save the temporary registers.
385 ;; Generate a new set of results.
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)
395 (inst xor y #x9908b0df)
397 (inst xor y (make-ea-for-vector-data state :index k :offset (+ 397 3)))
398 (inst mov (make-ea-for-vector-data state :index k :offset 3) y)
400 (inst cmp k (- 624 397))
403 (inst mov y (make-ea-for-vector-data state :index k :offset 3))
404 (inst mov tmp (make-ea-for-vector-data state :index k :offset (+ 1 3)))
405 (inst and y #x80000000)
406 (inst and tmp #x7fffffff)
410 (inst xor y #x9908b0df)
412 (inst xor y (make-ea-for-vector-data state :index k :offset (+ (- 397 624) 3)))
413 (inst mov (make-ea-for-vector-data state :index k :offset 3) y)
415 (inst cmp k (- 624 1))
418 (inst mov y (make-ea-for-vector-data state :offset (+ (- 624 1) 3)))
419 (inst mov tmp (make-ea-for-vector-data state :offset (+ 0 3)))
420 (inst and y #x80000000)
421 (inst and tmp #x7fffffff)
425 (inst xor y #x9908b0df)
427 (inst xor y (make-ea-for-vector-data state :offset (+ (- 397 1) 3)))
428 (inst mov (make-ea-for-vector-data state :offset (+ (- 624 1) 3)) y)
430 ;; Restore the temporary registers and return.