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 ebx unsigned-reg ebx-offset)
32 (:temp ecx unsigned-reg ecx-offset))
34 (declare (ignorable ebx))
36 (inst test x 3) ; fixnum?
37 (inst jmp :nz DO-STATIC-FUN) ; no - do generic
38 (inst test y 3) ; fixnum?
39 (inst jmp :z DO-BODY) ; yes - doit here
46 (make-ea :dword :base esp-tn :disp n-word-bytes))
47 (inst sub esp-tn (fixnumize 2))
48 (inst push eax) ; callers return addr
49 (inst mov ecx (fixnumize 2)) ; arg count
53 (static-function-offset
54 ',(symbolicate "TWO-ARG-" fun)))))
59 (define-generic-arith-routine (+ 10)
63 (inst rcr res 1) ; carry has correct sign
64 (inst sar res 1) ; remove type bits
68 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
69 (storew ecx res bignum-digits-offset other-pointer-lowtag))
73 (define-generic-arith-routine (- 10)
74 ;; FIXME: This is screwed up.
75 ;;; I can't figure out the flags on subtract. Overflow never gets
76 ;;; set and carry always does. (- 0 most-negative-fixnum) can't be
77 ;;; easily detected so just let the upper level stuff do it.
78 (inst jmp DO-STATIC-FUN)
84 (inst sar res 1) ; remove type bits
88 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
89 (storew ecx res bignum-digits-offset other-pointer-lowtag))
92 (define-generic-arith-routine (* 30)
93 (move eax x) ; must use eax for 64-bit result
94 (inst sar eax 2) ; remove *4 fixnum bias
95 (inst imul y) ; result in edx:eax
96 (inst jmp :no okay) ; still fixnum
98 ;; zzz jrd changed edx to ebx in here, as edx isn't listed as a temp, above
99 ;; pfw says that loses big -- edx is target for arg x and result res
100 ;; note that 'edx' is not defined -- using x
101 (inst shrd eax x 2) ; high bits from edx
102 (inst sar x 2) ; now shift edx too
104 (move ecx x) ; save high bits from cdq
105 (inst cdq) ; edx:eax <- sign-extend of eax
107 (inst jmp :e SINGLE-WORD-BIGNUM)
109 (with-fixed-allocation (res bignum-widetag (+ bignum-digits-offset 2))
110 (storew eax res bignum-digits-offset other-pointer-lowtag)
111 (storew ecx res (1+ bignum-digits-offset) other-pointer-lowtag))
116 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
117 (storew eax res bignum-digits-offset other-pointer-lowtag))
126 (define-assembly-routine (generic-negate
128 (:return-style :full-call)
132 ((:arg x (descriptor-reg any-reg) edx-offset)
133 (:res res (descriptor-reg any-reg) edx-offset)
135 (:temp eax unsigned-reg eax-offset)
136 (:temp ecx unsigned-reg ecx-offset))
142 (inst lea ebp-tn (make-ea :dword :base esp-tn :disp n-word-bytes))
143 (inst sub esp-tn (fixnumize 2))
145 (inst mov ecx (fixnumize 1)) ; arg count
146 (inst jmp (make-ea :dword
147 :disp (+ nil-value (static-function-offset '%negate))))
151 (inst neg res) ; (- most-negative-fixnum) is BIGNUM
153 (inst shr res 2) ; sign bit is data - remove type bits
156 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
157 (storew ecx res bignum-digits-offset other-pointer-lowtag))
163 (macrolet ((define-cond-assem-rtn (name translate static-fn test)
164 `(define-assembly-routine (,name
166 (:return-style :full-call)
168 (:translate ,translate)
170 ((:arg x (descriptor-reg any-reg) edx-offset)
171 (:arg y (descriptor-reg any-reg) edi-offset)
173 (:res res descriptor-reg edx-offset)
175 (:temp eax unsigned-reg eax-offset)
176 (:temp ecx unsigned-reg ecx-offset))
178 ;; KLUDGE: The "3" here is a mask for the bits which will be
179 ;; zero in a fixnum. It should have a symbolic name. (Actually,
180 ;; it might already have a symbolic name which the coder
181 ;; couldn't be bothered to use..) -- WHN 19990917
183 (inst jmp :nz TAIL-CALL-TO-STATIC-FN)
185 (inst jmp :z INLINE-FIXNUM-COMPARE)
187 TAIL-CALL-TO-STATIC-FN
190 (inst lea ebp-tn (make-ea :dword
193 (inst sub esp-tn (fixnumize 2)) ; FIXME: Push 2 words on stack,
196 (inst mov ecx (fixnumize 2)) ; FIXME: FIXNUMIZE and
197 ; SINGLE-FLOAT-BITS are parallel,
198 ; should be named parallelly.
199 (inst jmp (make-ea :dword
201 (static-function-offset
204 INLINE-FIXNUM-COMPARE
206 (inst jmp ,test RETURN-TRUE)
207 (inst mov res nil-value)
208 ;; FIXME: A note explaining this return convention, or a
209 ;; symbolic name for it, would be nice. (It looks as though we
210 ;; should be hand-crafting the same return sequence as would be
211 ;; produced by GENERATE-RETURN-SEQUENCE, but in that case it's
212 ;; not clear why we don't just jump to the end of this function
213 ;; to share the return sequence there.
219 (load-symbol res t))))
221 (define-cond-assem-rtn generic-< < two-arg-< :l)
222 (define-cond-assem-rtn generic-> > two-arg-> :g))
224 (define-assembly-routine (generic-eql
226 (:return-style :full-call)
230 ((:arg x (descriptor-reg any-reg) edx-offset)
231 (:arg y (descriptor-reg any-reg) edi-offset)
233 (:res res descriptor-reg edx-offset)
235 (:temp eax unsigned-reg eax-offset)
236 (:temp ecx unsigned-reg ecx-offset))
238 (inst jmp :e RETURN-T)
240 (inst jmp :z RETURN-NIL)
242 (inst jmp :nz DO-STATIC-FN)
245 (inst mov res nil-value)
253 (inst lea ebp-tn (make-ea :dword :base esp-tn :disp n-word-bytes))
254 (inst sub esp-tn (fixnumize 2))
256 (inst mov ecx (fixnumize 2))
257 (inst jmp (make-ea :dword
258 :disp (+ nil-value (static-function-offset 'eql))))
262 ;; FIXME: I don't understand how we return from here..
265 (define-assembly-routine (generic-=
267 (:return-style :full-call)
271 ((:arg x (descriptor-reg any-reg) edx-offset)
272 (:arg y (descriptor-reg any-reg) edi-offset)
274 (:res res descriptor-reg edx-offset)
276 (:temp eax unsigned-reg eax-offset)
277 (:temp ecx unsigned-reg ecx-offset)
279 (inst test x 3) ; descriptor?
280 (inst jmp :nz DO-STATIC-FN) ; yes, do it here
281 (inst test y 3) ; descriptor?
282 (inst jmp :nz DO-STATIC-FN)
284 (inst jmp :e RETURN-T) ; ok
286 (inst mov res nil-value)
294 (inst lea ebp-tn (make-ea :dword :base esp-tn :disp n-word-bytes))
295 (inst sub esp-tn (fixnumize 2))
297 (inst mov ecx (fixnumize 2))
298 (inst jmp (make-ea :dword
299 :disp (+ nil-value (static-function-offset 'two-arg-=))))
305 ;;; Support for the Mersenne Twister, MT19937, random number generator
306 ;;; due to Matsumoto and Nishimura.
308 ;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A
309 ;;; 623-dimensionally equidistributed uniform pseudorandom number
310 ;;; generator.", ACM Transactions on Modeling and Computer Simulation,
314 ;;; 0-1: Constant matrix A. [0, #x9908b0df] (not used here)
315 ;;; 2: Index; init. to 1.
318 ;;; This assembly routine is called from the inline VOP and updates
319 ;;; the state vector with new random numbers. The state vector is
320 ;;; passed in the EAX register.
321 #+sb-assembling ; We don't want a vop for this one.
322 (define-assembly-routine
323 (random-mt19937-update)
324 ((:temp state unsigned-reg eax-offset)
325 (:temp k unsigned-reg ebx-offset)
326 (:temp y unsigned-reg ecx-offset)
327 (:temp tmp unsigned-reg edx-offset))
329 ;; Save the temporary registers.
334 ;; Generate a new set of results.
337 (inst mov y (make-ea :dword :base state :index k :scale 4
338 :disp (- (* (+ 3 vector-data-offset)
340 other-pointer-lowtag)))
341 (inst mov tmp (make-ea :dword :base state :index k :scale 4
342 :disp (- (* (+ 1 3 vector-data-offset)
344 other-pointer-lowtag)))
345 (inst and y #x80000000)
346 (inst and tmp #x7fffffff)
350 (inst xor y #x9908b0df)
352 (inst xor y (make-ea :dword :base state :index k :scale 4
353 :disp (- (* (+ 397 3 vector-data-offset)
355 other-pointer-lowtag)))
356 (inst mov (make-ea :dword :base state :index k :scale 4
357 :disp (- (* (+ 3 vector-data-offset)
359 other-pointer-lowtag))
362 (inst cmp k (- 624 397))
365 (inst mov y (make-ea :dword :base state :index k :scale 4
366 :disp (- (* (+ 3 vector-data-offset)
368 other-pointer-lowtag)))
369 (inst mov tmp (make-ea :dword :base state :index k :scale 4
370 :disp (- (* (+ 1 3 vector-data-offset)
372 other-pointer-lowtag)))
373 (inst and y #x80000000)
374 (inst and tmp #x7fffffff)
378 (inst xor y #x9908b0df)
380 (inst xor y (make-ea :dword :base state :index k :scale 4
381 :disp (- (* (+ (- 397 624) 3 vector-data-offset)
383 other-pointer-lowtag)))
384 (inst mov (make-ea :dword :base state :index k :scale 4
385 :disp (- (* (+ 3 vector-data-offset)
387 other-pointer-lowtag))
390 (inst cmp k (- 624 1))
393 (inst mov y (make-ea :dword :base state
394 :disp (- (* (+ (- 624 1) 3 vector-data-offset)
396 other-pointer-lowtag)))
397 (inst mov tmp (make-ea :dword :base state
398 :disp (- (* (+ 0 3 vector-data-offset)
400 other-pointer-lowtag)))
401 (inst and y #x80000000)
402 (inst and tmp #x7fffffff)
406 (inst xor y #x9908b0df)
408 (inst xor y (make-ea :dword :base state
409 :disp (- (* (+ (- 397 1) 3 vector-data-offset)
411 other-pointer-lowtag)))
412 (inst mov (make-ea :dword :base state
413 :disp (- (* (+ (- 624 1) 3 vector-data-offset)
415 other-pointer-lowtag))
418 ;; Restore the temporary registers and return.