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 (* n-word-bytes 1))
45 (inst mov rbp-tn rsp-tn)
46 (inst sub rsp-tn (* n-word-bytes 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))))))))
57 (define-generic-arith-routine (+ 10)
61 ;; Unbox the overflowed result, recovering the correct sign from
62 ;; the carry flag, then re-box as a bignum.
64 ,@(when (> n-fixnum-tag-bits 1) ; don't shift by 0
65 '((inst sar res (1- n-fixnum-tag-bits))))
69 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
70 (storew rcx res bignum-digits-offset other-pointer-lowtag))
75 (define-generic-arith-routine (- 10)
79 ;; Unbox the overflowed result, recovering the correct sign from
80 ;; the carry flag, then re-box as a bignum.
81 (inst cmc) ; carry has correct sign now
83 ,@(when (> n-fixnum-tag-bits 1) ; don't shift by 0
84 '((inst sar res (1- n-fixnum-tag-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 n-fixnum-tag-bits) ; remove *8 fixnum bias
95 (inst imul y) ; result in edx:eax
96 (inst jmp :no OKAY) ; still fixnum
98 (inst shrd rax x n-fixnum-tag-bits) ; high bits from edx
99 (inst sar x n-fixnum-tag-bits) ; now shift edx too
101 (move rcx x) ; save high bits from cqo
102 (inst cqo) ; edx:eax <- sign-extend of eax
104 (inst jmp :e SINGLE-WORD-BIGNUM)
106 (with-fixed-allocation (res bignum-widetag (+ bignum-digits-offset 2))
107 (storew rax res bignum-digits-offset other-pointer-lowtag)
108 (storew rcx res (1+ bignum-digits-offset) other-pointer-lowtag))
113 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
114 (storew rax res bignum-digits-offset other-pointer-lowtag))
123 (define-assembly-routine (generic-negate
125 (:return-style :full-call)
129 ((:arg x (descriptor-reg any-reg) rdx-offset)
130 (:res res (descriptor-reg any-reg) rdx-offset)
132 (:temp rax unsigned-reg rax-offset)
133 (:temp rcx unsigned-reg rcx-offset))
134 (inst test x fixnum-tag-mask)
138 (inst mov rbp-tn rsp-tn)
139 (inst sub rsp-tn (* n-word-bytes 1))
140 (inst push (make-ea :qword :base rbp-tn
141 :disp (frame-byte-offset return-pc-save-offset)))
142 (inst mov rcx (fixnumize 1)) ; arg count
143 (inst jmp (make-ea :qword
144 :disp (+ nil-value (static-fun-offset '%negate))))
148 (inst neg res) ; (- most-negative-fixnum) is BIGNUM
150 (inst shr res n-fixnum-tag-bits) ; sign bit is data - remove type bits
153 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
154 (storew rcx res bignum-digits-offset other-pointer-lowtag))
160 (macrolet ((define-cond-assem-rtn (name translate static-fn test)
161 (declare (ignorable translate static-fn))
163 `(define-assembly-routine (,name
164 (:return-style :none))
165 ((:arg x (descriptor-reg any-reg) rdx-offset)
166 (:arg y (descriptor-reg any-reg) rdi-offset)
168 (:temp rcx unsigned-reg rcx-offset))
172 (inst test rcx fixnum-tag-mask)
173 (inst jmp :nz DO-STATIC-FUN) ; are both fixnums?
180 (inst mov rbp-tn rsp-tn)
181 (inst sub rsp-tn (* n-word-bytes 3))
182 (inst mov (make-ea :qword :base rsp-tn
183 :disp (frame-byte-offset
188 (inst lea rbp-tn (make-ea :qword :base rsp-tn
189 :disp (frame-byte-offset
193 (inst mov rcx (fixnumize 2))
194 (inst call (make-ea :qword
196 (static-fun-offset ',static-fn))))
197 ;; HACK: We depend on NIL having the lowest address of all
198 ;; static symbols (including T)
200 (:l `((inst mov y (1+ nil-value))
202 (:g `((inst cmp x (1+ nil-value)))))
207 (:translate ,translate)
210 (:args (x :scs (descriptor-reg any-reg) :target rdx)
211 (y :scs (descriptor-reg any-reg) :target rdi))
213 (:temporary (:sc unsigned-reg :offset rdx-offset
216 (:temporary (:sc unsigned-reg :offset rdi-offset
220 (:temporary (:sc unsigned-reg :offset rcx-offset
227 (inst lea rcx (make-ea :qword
228 :disp (make-fixup ',name :assembly-routine)))
231 (define-cond-assem-rtn generic-< < two-arg-< :l)
232 (define-cond-assem-rtn generic-> > two-arg-> :g))
235 (define-assembly-routine (generic-eql
236 (:return-style :none))
237 ((:arg x (descriptor-reg any-reg) rdx-offset)
238 (:arg y (descriptor-reg any-reg) rdi-offset)
240 (:temp rcx unsigned-reg rcx-offset))
244 (inst test rcx fixnum-tag-mask)
245 (inst jmp :nz DO-STATIC-FUN)
247 ;; At least one fixnum
253 (inst mov rbp-tn rsp-tn)
254 (inst sub rsp-tn (* n-word-bytes 3))
255 (inst mov (make-ea :qword :base rsp-tn
256 :disp (frame-byte-offset
261 (inst lea rbp-tn (make-ea :qword :base rsp-tn
262 :disp (frame-byte-offset
266 (inst mov rcx (fixnumize 2))
267 (inst call (make-ea :qword
268 :disp (+ nil-value (static-fun-offset 'eql))))
275 (define-vop (generic-eql)
279 (:args (x :scs (descriptor-reg any-reg) :target rdx)
280 (y :scs (descriptor-reg any-reg) :target rdi))
282 (:temporary (:sc unsigned-reg :offset rdx-offset
285 (:temporary (:sc unsigned-reg :offset rdi-offset
289 (:temporary (:sc unsigned-reg :offset rcx-offset
296 (inst lea rcx (make-ea :qword
297 :disp (make-fixup 'generic-eql :assembly-routine)))
301 (define-assembly-routine (generic-=
302 (:return-style :none))
303 ((:arg x (descriptor-reg any-reg) rdx-offset)
304 (:arg y (descriptor-reg any-reg) rdi-offset)
306 (:temp rcx unsigned-reg rcx-offset))
309 (inst test rcx fixnum-tag-mask)
310 (inst jmp :nz DO-STATIC-FUN)
318 (inst mov rbp-tn rsp-tn)
319 (inst sub rsp-tn (* n-word-bytes 3))
320 (inst mov (make-ea :qword :base rsp-tn
321 :disp (frame-byte-offset
326 (inst lea rbp-tn (make-ea :qword :base rsp-tn
327 :disp (frame-byte-offset
332 (inst mov rcx (fixnumize 2))
333 (inst call (make-ea :qword
334 :disp (+ nil-value (static-fun-offset 'two-arg-=))))
341 (define-vop (generic-=)
345 (:args (x :scs (descriptor-reg any-reg) :target rdx)
346 (y :scs (descriptor-reg any-reg) :target rdi))
348 (:temporary (:sc unsigned-reg :offset rdx-offset
351 (:temporary (:sc unsigned-reg :offset rdi-offset
355 (:temporary (:sc unsigned-reg :offset rcx-offset
362 (inst lea rcx (make-ea :qword
363 :disp (make-fixup 'generic-= :assembly-routine)))