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) rdx-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) rdx-offset)
30 (:temp rax unsigned-reg rax-offset)
31 (:temp rbx unsigned-reg rbx-offset)
32 (:temp rcx unsigned-reg rcx-offset))
34 (declare (ignorable rbx))
36 (inst test x 7) ; fixnum?
37 (inst jmp :nz DO-STATIC-FUN) ; no - do generic
38 (inst test y 7) ; fixnum?
39 (inst jmp :z DO-BODY) ; yes - doit here
46 (make-ea :qword :base rsp-tn :disp n-word-bytes))
47 (inst sub rsp-tn (fixnumize 2))
48 (inst push rax) ; callers return addr
49 (inst mov rcx (fixnumize 2)) ; arg count
54 ',(symbolicate "TWO-ARG-" fun)))))
59 (define-generic-arith-routine (+ 10)
63 (inst rcr res 1) ; carry has correct sign
64 (inst sar res 2) ; remove type bits
68 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
69 (storew rcx 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 2) ; remove type bits
88 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
89 (storew rcx res bignum-digits-offset other-pointer-lowtag))
92 (define-generic-arith-routine (* 30)
93 (move rax x) ; must use eax for 64-bit result
94 (inst sar rax 3) ; 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 rax x 3) ; high bits from edx
102 (inst sar x 3) ; now shift edx too
104 (move rcx x) ; save high bits from cqo
105 (inst cqo) ; 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 rax res bignum-digits-offset other-pointer-lowtag)
111 (storew rcx res (1+ bignum-digits-offset) other-pointer-lowtag))
116 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
117 (storew rax 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) rdx-offset)
133 (:res res (descriptor-reg any-reg) rdx-offset)
135 (:temp rax unsigned-reg rax-offset)
136 (:temp rcx unsigned-reg rcx-offset))
142 (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes))
143 (inst sub rsp-tn (fixnumize 2))
145 (inst mov rcx (fixnumize 1)) ; arg count
146 (inst jmp (make-ea :qword
147 :disp (+ nil-value (static-fun-offset '%negate))))
151 (inst neg res) ; (- most-negative-fixnum) is BIGNUM
153 (inst shr res 3) ; sign bit is data - remove type bits
156 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
157 (storew rcx 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) rdx-offset)
171 (:arg y (descriptor-reg any-reg) rdi-offset)
173 (:res res descriptor-reg rdx-offset)
175 (:temp eax unsigned-reg rax-offset)
176 (:temp ecx unsigned-reg rcx-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 rbp-tn (make-ea :qword
193 (inst sub rsp-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 :qword
201 (static-fun-offset ',static-fn))))
203 INLINE-FIXNUM-COMPARE
205 (inst jmp ,test RETURN-TRUE)
206 (inst mov res nil-value)
207 ;; FIXME: A note explaining this return convention, or a
208 ;; symbolic name for it, would be nice. (It looks as though we
209 ;; should be hand-crafting the same return sequence as would be
210 ;; produced by GENERATE-RETURN-SEQUENCE, but in that case it's
211 ;; not clear why we don't just jump to the end of this function
212 ;; to share the return sequence there.
218 (load-symbol res t))))
220 (define-cond-assem-rtn generic-< < two-arg-< :l)
221 (define-cond-assem-rtn generic-> > two-arg-> :g))
223 (define-assembly-routine (generic-eql
225 (:return-style :full-call)
229 ((:arg x (descriptor-reg any-reg) rdx-offset)
230 (:arg y (descriptor-reg any-reg) rdi-offset)
232 (:res res descriptor-reg rdx-offset)
234 (:temp eax unsigned-reg rax-offset)
235 (:temp ecx unsigned-reg rcx-offset))
237 (inst jmp :e RETURN-T)
239 (inst jmp :z RETURN-NIL)
241 (inst jmp :nz DO-STATIC-FN)
244 (inst mov res nil-value)
252 (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes))
253 (inst sub rsp-tn (fixnumize 2))
255 (inst mov ecx (fixnumize 2))
256 (inst jmp (make-ea :qword
257 :disp (+ nil-value (static-fun-offset 'eql))))
261 ;; FIXME: I don't understand how we return from here..
264 (define-assembly-routine (generic-=
266 (:return-style :full-call)
270 ((:arg x (descriptor-reg any-reg) rdx-offset)
271 (:arg y (descriptor-reg any-reg) rdi-offset)
273 (:res res descriptor-reg rdx-offset)
275 (:temp eax unsigned-reg rax-offset)
276 (:temp ecx unsigned-reg rcx-offset)
278 (inst test x 7) ; descriptor?
279 (inst jmp :nz DO-STATIC-FN) ; yes, do it here
280 (inst test y 7) ; descriptor?
281 (inst jmp :nz DO-STATIC-FN)
283 (inst jmp :e RETURN-T) ; ok
285 (inst mov res nil-value)
293 (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes))
294 (inst sub rsp-tn (fixnumize 2))
296 (inst mov ecx (fixnumize 2))
297 (inst jmp (make-ea :qword
298 :disp (+ nil-value (static-fun-offset 'two-arg-=))))