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
39 (inst clc) ; single-value return
43 ;; Same as: (inst enter (fixnumize 1))
45 (inst mov rbp-tn rsp-tn)
46 (inst sub rsp-tn (fixnumize 1))
47 (inst push (make-ea :qword :base rbp-tn
48 :disp (frame-byte-offset return-pc-save-offset)))
49 (inst mov rcx (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 2) ; remove type bits
65 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
66 (storew rcx 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 2) ; remove type bits
80 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
81 (storew rcx res bignum-digits-offset other-pointer-lowtag))
84 (define-generic-arith-routine (* 30)
85 (move rax x) ; must use eax for 64-bit result
86 (inst sar rax n-fixnum-tag-bits) ; remove *8 fixnum bias
87 (inst imul y) ; result in edx:eax
88 (inst jmp :no OKAY) ; still fixnum
90 (inst shrd rax x n-fixnum-tag-bits) ; high bits from edx
91 (inst sar x n-fixnum-tag-bits) ; now shift edx too
93 (move rcx x) ; save high bits from cqo
94 (inst cqo) ; edx:eax <- sign-extend of eax
96 (inst jmp :e SINGLE-WORD-BIGNUM)
98 (with-fixed-allocation (res bignum-widetag (+ bignum-digits-offset 2))
99 (storew rax res bignum-digits-offset other-pointer-lowtag)
100 (storew rcx res (1+ bignum-digits-offset) other-pointer-lowtag))
105 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
106 (storew rax res bignum-digits-offset other-pointer-lowtag))
115 (define-assembly-routine (generic-negate
117 (:return-style :full-call)
121 ((:arg x (descriptor-reg any-reg) rdx-offset)
122 (:res res (descriptor-reg any-reg) rdx-offset)
124 (:temp rax unsigned-reg rax-offset)
125 (:temp rcx unsigned-reg rcx-offset))
126 (inst test x fixnum-tag-mask)
130 (inst mov rbp-tn rsp-tn)
131 (inst sub rsp-tn (fixnumize 1))
132 (inst push (make-ea :qword :base rbp-tn
133 :disp (frame-byte-offset return-pc-save-offset)))
134 (inst mov rcx (fixnumize 1)) ; arg count
135 (inst jmp (make-ea :qword
136 :disp (+ nil-value (static-fun-offset '%negate))))
140 (inst neg res) ; (- most-negative-fixnum) is BIGNUM
142 (inst shr res n-fixnum-tag-bits) ; sign bit is data - remove type bits
145 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
146 (storew rcx res bignum-digits-offset other-pointer-lowtag))
152 (macrolet ((define-cond-assem-rtn (name translate static-fn test)
153 (declare (ignorable translate static-fn))
155 `(define-assembly-routine (,name
156 (:return-style :none))
157 ((:arg x (descriptor-reg any-reg) rdx-offset)
158 (:arg y (descriptor-reg any-reg) rdi-offset)
160 (:temp rcx unsigned-reg rcx-offset))
164 (inst test rcx fixnum-tag-mask)
165 (inst jmp :nz DO-STATIC-FUN) ; are both fixnums?
171 (inst sub rsp-tn (fixnumize 3))
172 (inst mov (make-ea :qword :base rsp-tn
173 :disp (frame-byte-offset
178 (inst lea rbp-tn (make-ea :qword :base rsp-tn
179 :disp (frame-byte-offset
183 (inst mov rcx (fixnumize 2))
184 (inst call (make-ea :qword
186 (static-fun-offset ',static-fn))))
187 ;; HACK: We depend on NIL having the lowest address of all
188 ;; static symbols (including T)
190 (:l `((inst mov y (1+ nil-value))
192 (:g `((inst cmp x (1+ nil-value)))))
196 (:translate ,translate)
199 (:args (x :scs (descriptor-reg any-reg) :target rdx)
200 (y :scs (descriptor-reg any-reg) :target rdi))
202 (:temporary (:sc unsigned-reg :offset rdx-offset
205 (:temporary (:sc unsigned-reg :offset rdi-offset
209 (:temporary (:sc unsigned-reg :offset rcx-offset
216 (inst lea rcx (make-ea :qword
217 :disp (make-fixup ',name :assembly-routine)))
220 (define-cond-assem-rtn generic-< < two-arg-< :l)
221 (define-cond-assem-rtn generic-> > two-arg-> :g))
224 (define-assembly-routine (generic-eql
225 (:return-style :none))
226 ((:arg x (descriptor-reg any-reg) rdx-offset)
227 (:arg y (descriptor-reg any-reg) rdi-offset)
229 (:temp rcx unsigned-reg rcx-offset))
233 (inst test rcx fixnum-tag-mask)
234 (inst jmp :nz DO-STATIC-FUN)
236 ;; At least one fixnum
241 (inst sub rsp-tn (fixnumize 3))
242 (inst mov (make-ea :qword :base rsp-tn
243 :disp (frame-byte-offset
248 (inst lea rbp-tn (make-ea :qword :base rsp-tn
249 :disp (frame-byte-offset
253 (inst mov rcx (fixnumize 2))
254 (inst call (make-ea :qword
255 :disp (+ nil-value (static-fun-offset 'eql))))
261 (define-vop (generic-eql)
265 (:args (x :scs (descriptor-reg any-reg) :target rdx)
266 (y :scs (descriptor-reg any-reg) :target rdi))
268 (:temporary (:sc unsigned-reg :offset rdx-offset
271 (:temporary (:sc unsigned-reg :offset rdi-offset
275 (:temporary (:sc unsigned-reg :offset rcx-offset
282 (inst lea rcx (make-ea :qword
283 :disp (make-fixup 'generic-eql :assembly-routine)))
287 (define-assembly-routine (generic-=
288 (:return-style :none))
289 ((:arg x (descriptor-reg any-reg) rdx-offset)
290 (:arg y (descriptor-reg any-reg) rdi-offset)
292 (:temp rcx unsigned-reg rcx-offset))
295 (inst test rcx fixnum-tag-mask)
296 (inst jmp :nz DO-STATIC-FUN)
303 (inst sub rsp-tn (fixnumize 3))
304 (inst mov (make-ea :qword :base rsp-tn
305 :disp (frame-byte-offset
310 (inst lea rbp-tn (make-ea :qword :base rsp-tn
311 :disp (frame-byte-offset
316 (inst mov rcx (fixnumize 2))
317 (inst call (make-ea :qword
318 :disp (+ nil-value (static-fun-offset 'two-arg-=))))
324 (define-vop (generic-=)
328 (:args (x :scs (descriptor-reg any-reg) :target rdx)
329 (y :scs (descriptor-reg any-reg) :target rdi))
331 (:temporary (:sc unsigned-reg :offset rdx-offset
334 (:temporary (:sc unsigned-reg :offset rdi-offset
338 (:temporary (:sc unsigned-reg :offset rcx-offset
345 (inst lea rcx (make-ea :qword
346 :disp (make-fixup 'generic-= :assembly-routine)))