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 rcx unsigned-reg rcx-offset))
35 (inst test rcx fixnum-tag-mask) ; both fixnums?
36 (inst jmp :nz DO-STATIC-FUN) ; no - do generic
47 (make-ea :qword :base rsp-tn :disp n-word-bytes))
48 (inst sub rsp-tn (fixnumize 2))
49 (inst push rax) ; callers return addr
50 (inst mov rcx (fixnumize 2)) ; arg count
55 ',(symbolicate "TWO-ARG-" fun))))))))
57 (define-generic-arith-routine (+ 10)
61 (inst rcr res 1) ; carry has correct sign
62 (inst sar res 2) ; remove type bits
66 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
67 (storew rcx res bignum-digits-offset other-pointer-lowtag))
71 (define-generic-arith-routine (- 10)
75 (inst cmc) ; carry has correct sign now
77 (inst sar res 2) ; remove type bits
81 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
82 (storew rcx res bignum-digits-offset other-pointer-lowtag))
85 (define-generic-arith-routine (* 30)
86 (move rax x) ; must use eax for 64-bit result
87 (inst sar rax n-fixnum-tag-bits) ; remove *8 fixnum bias
88 (inst imul y) ; result in edx:eax
89 (inst jmp :no OKAY) ; still fixnum
91 (inst shrd rax x n-fixnum-tag-bits) ; high bits from edx
92 (inst sar x n-fixnum-tag-bits) ; now shift edx too
94 (move rcx x) ; save high bits from cqo
95 (inst cqo) ; edx:eax <- sign-extend of eax
97 (inst jmp :e SINGLE-WORD-BIGNUM)
99 (with-fixed-allocation (res bignum-widetag (+ bignum-digits-offset 2))
100 (storew rax res bignum-digits-offset other-pointer-lowtag)
101 (storew rcx res (1+ bignum-digits-offset) other-pointer-lowtag))
106 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
107 (storew rax res bignum-digits-offset other-pointer-lowtag))
116 (define-assembly-routine (generic-negate
118 (:return-style :full-call)
122 ((:arg x (descriptor-reg any-reg) rdx-offset)
123 (:res res (descriptor-reg any-reg) rdx-offset)
125 (:temp rax unsigned-reg rax-offset)
126 (:temp rcx unsigned-reg rcx-offset))
127 (inst test x fixnum-tag-mask)
132 (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes))
133 (inst sub rsp-tn (fixnumize 2))
135 (inst mov rcx (fixnumize 1)) ; arg count
136 (inst jmp (make-ea :qword
137 :disp (+ nil-value (static-fun-offset '%negate))))
141 (inst neg res) ; (- most-negative-fixnum) is BIGNUM
143 (inst shr res n-fixnum-tag-bits) ; sign bit is data - remove type bits
146 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
147 (storew rcx res bignum-digits-offset other-pointer-lowtag))
153 (macrolet ((define-cond-assem-rtn (name translate static-fn test)
154 (declare (ignorable translate static-fn))
156 `(define-assembly-routine (,name
157 (:return-style :none))
158 ((:arg x (descriptor-reg any-reg) rdx-offset)
159 (:arg y (descriptor-reg any-reg) rdi-offset)
161 (:temp rcx unsigned-reg rcx-offset))
165 (inst test rcx fixnum-tag-mask)
166 (inst jmp :nz DO-STATIC-FUN)
173 (inst sub rsp-tn (fixnumize 3))
174 (inst mov (make-ea :qword
176 :disp (fixnumize -1))
179 (inst mov rcx (fixnumize 2))
180 (inst call (make-ea :qword
182 (static-fun-offset ',static-fn))))
183 ;; HACK: We depend on NIL having the lowest address of all
184 ;; static symbols (including T)
186 (:l `((inst mov y (1+ nil-value))
188 (:g `((inst cmp x (1+ nil-value)))))
192 (:translate ,translate)
195 (:args (x :scs (descriptor-reg any-reg) :target rdx)
196 (y :scs (descriptor-reg any-reg) :target rdi))
198 (:temporary (:sc unsigned-reg :offset rdx-offset
201 (:temporary (:sc unsigned-reg :offset rdi-offset
205 (:temporary (:sc unsigned-reg :offset rcx-offset
212 (inst lea rcx (make-ea :qword
213 :disp (make-fixup ',name :assembly-routine)))
216 (define-cond-assem-rtn generic-< < two-arg-< :l)
217 (define-cond-assem-rtn generic-> > two-arg-> :g))
220 (define-assembly-routine (generic-eql
221 (:return-style :none))
222 ((:arg x (descriptor-reg any-reg) rdx-offset)
223 (:arg y (descriptor-reg any-reg) rdi-offset)
225 (:temp rcx unsigned-reg rcx-offset))
229 (inst test rcx fixnum-tag-mask)
230 (inst jmp :nz DO-STATIC-FUN)
232 ;; At least one fixnum
238 (inst sub rsp-tn (fixnumize 3))
239 (inst mov (make-ea :qword
241 :disp (fixnumize -1))
244 (inst mov rcx (fixnumize 2))
245 (inst call (make-ea :qword
246 :disp (+ nil-value (static-fun-offset 'eql))))
252 (define-vop (generic-eql)
256 (:args (x :scs (descriptor-reg any-reg) :target rdx)
257 (y :scs (descriptor-reg any-reg) :target rdi))
259 (:temporary (:sc unsigned-reg :offset rdx-offset
262 (:temporary (:sc unsigned-reg :offset rdi-offset
266 (:temporary (:sc unsigned-reg :offset rcx-offset
273 (inst lea rcx (make-ea :qword
274 :disp (make-fixup 'generic-eql :assembly-routine)))
278 (define-assembly-routine (generic-=
279 (:return-style :none))
280 ((:arg x (descriptor-reg any-reg) rdx-offset)
281 (:arg y (descriptor-reg any-reg) rdi-offset)
283 (:temp rcx unsigned-reg rcx-offset))
286 (inst test rcx fixnum-tag-mask)
287 (inst jmp :nz DO-STATIC-FUN)
295 (inst sub rsp-tn (fixnumize 3))
296 (inst mov (make-ea :qword
298 :disp (fixnumize -1))
301 (inst mov rcx (fixnumize 2))
302 (inst call (make-ea :qword
303 :disp (+ nil-value (static-fun-offset 'two-arg-=))))
309 (define-vop (generic-=)
313 (:args (x :scs (descriptor-reg any-reg) :target rdx)
314 (y :scs (descriptor-reg any-reg) :target rdi))
316 (:temporary (:sc unsigned-reg :offset rdx-offset
319 (:temporary (:sc unsigned-reg :offset rdi-offset
323 (:temporary (:sc unsigned-reg :offset rcx-offset
330 (inst lea rcx (make-ea :qword
331 :disp (make-fixup 'generic-= :assembly-routine)))