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) rdi-offset)
26 (:res res (descriptor-reg any-reg) rdx-offset)
28 (:temp rax unsigned-reg rax-offset)
29 (:temp rcx unsigned-reg rcx-offset))
33 (inst test rcx fixnum-tag-mask) ; both fixnums?
34 (inst jmp :nz DO-STATIC-FUN) ; no - do generic
37 (inst clc) ; single-value return
41 ;; Same as: (inst enter (* n-word-bytes 1))
43 (inst mov rbp-tn rsp-tn)
44 (inst sub rsp-tn (* n-word-bytes 1))
45 (inst push (make-ea :qword :base rbp-tn
46 :disp (frame-byte-offset return-pc-save-offset)))
47 (inst mov rcx (fixnumize 2)) ; arg count
52 ',(symbolicate "TWO-ARG-" fun))))))))
55 (define-generic-arith-routine (+ 10)
59 ;; Unbox the overflowed result, recovering the correct sign from
60 ;; the carry flag, then re-box as a bignum.
62 ,@(when (> n-fixnum-tag-bits 1) ; don't shift by 0
63 '((inst sar res (1- n-fixnum-tag-bits))))
67 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
68 (storew rcx res bignum-digits-offset other-pointer-lowtag))
73 (define-generic-arith-routine (- 10)
77 ;; Unbox the overflowed result, recovering the correct sign from
78 ;; the carry flag, then re-box as a bignum.
79 (inst cmc) ; carry has correct sign now
81 ,@(when (> n-fixnum-tag-bits 1) ; don't shift by 0
82 '((inst sar res (1- n-fixnum-tag-bits))))
86 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
87 (storew rcx res bignum-digits-offset other-pointer-lowtag))
90 (define-generic-arith-routine (* 30)
91 (move rax x) ; must use eax for 64-bit result
92 (inst sar rax n-fixnum-tag-bits) ; remove *8 fixnum bias
93 (inst imul y) ; result in edx:eax
94 (inst jmp :no OKAY) ; still fixnum
96 (inst shrd rax x n-fixnum-tag-bits) ; high bits from edx
97 (inst sar x n-fixnum-tag-bits) ; now shift edx too
99 (move rcx x) ; save high bits from cqo
100 (inst cqo) ; edx:eax <- sign-extend of eax
102 (inst jmp :e SINGLE-WORD-BIGNUM)
104 (with-fixed-allocation (res bignum-widetag (+ bignum-digits-offset 2))
105 (storew rax res bignum-digits-offset other-pointer-lowtag)
106 (storew rcx res (1+ bignum-digits-offset) other-pointer-lowtag))
111 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
112 (storew rax res bignum-digits-offset other-pointer-lowtag))
121 (define-assembly-routine (generic-negate
123 (:return-style :full-call)
127 ((:arg x (descriptor-reg any-reg) rdx-offset)
128 (:res res (descriptor-reg any-reg) rdx-offset)
130 (:temp rax unsigned-reg rax-offset)
131 (:temp rcx unsigned-reg rcx-offset))
132 (inst test x fixnum-tag-mask)
136 (inst mov rbp-tn rsp-tn)
137 (inst sub rsp-tn (* n-word-bytes 1))
138 (inst push (make-ea :qword :base rbp-tn
139 :disp (frame-byte-offset return-pc-save-offset)))
140 (inst mov rcx (fixnumize 1)) ; arg count
141 (inst jmp (make-ea :qword
142 :disp (+ nil-value (static-fun-offset '%negate))))
146 (inst neg res) ; (- most-negative-fixnum) is BIGNUM
148 (inst shr res n-fixnum-tag-bits) ; sign bit is data - remove type bits
151 (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
152 (storew rcx res bignum-digits-offset other-pointer-lowtag))
158 (macrolet ((define-cond-assem-rtn (name translate static-fn test)
159 (declare (ignorable translate static-fn))
161 `(define-assembly-routine (,name
162 (:return-style :none))
163 ((:arg x (descriptor-reg any-reg) rdx-offset)
164 (:arg y (descriptor-reg any-reg) rdi-offset)
166 (:temp rcx unsigned-reg rcx-offset))
170 (inst test rcx fixnum-tag-mask)
171 (inst jmp :nz DO-STATIC-FUN) ; are both fixnums?
178 (inst mov rbp-tn rsp-tn)
179 (inst sub rsp-tn (* n-word-bytes 3))
180 (inst mov (make-ea :qword :base rsp-tn
181 :disp (frame-byte-offset
186 (inst lea rbp-tn (make-ea :qword :base rsp-tn
187 :disp (frame-byte-offset
191 (inst mov rcx (fixnumize 2))
192 (inst call (make-ea :qword
194 (static-fun-offset ',static-fn))))
195 ;; HACK: We depend on NIL having the lowest address of all
196 ;; static symbols (including T)
198 (:l `((inst mov y (1+ nil-value))
200 (:g `((inst cmp x (1+ nil-value)))))
205 (:translate ,translate)
208 (:args (x :scs (descriptor-reg any-reg) :target rdx)
209 (y :scs (descriptor-reg any-reg) :target rdi))
211 (:temporary (:sc unsigned-reg :offset rdx-offset
214 (:temporary (:sc unsigned-reg :offset rdi-offset
218 (:temporary (:sc unsigned-reg :offset rcx-offset
225 (inst mov rcx (make-fixup ',name :assembly-routine))
228 (define-cond-assem-rtn generic-< < two-arg-< :l)
229 (define-cond-assem-rtn generic-> > two-arg-> :g))
232 (define-assembly-routine (generic-eql
233 (:return-style :none))
234 ((:arg x (descriptor-reg any-reg) rdx-offset)
235 (:arg y (descriptor-reg any-reg) rdi-offset)
237 (:temp rcx unsigned-reg rcx-offset))
241 (inst test rcx fixnum-tag-mask)
242 (inst jmp :nz DO-STATIC-FUN)
244 ;; At least one fixnum
250 (inst mov rbp-tn rsp-tn)
251 (inst sub rsp-tn (* n-word-bytes 3))
252 (inst mov (make-ea :qword :base rsp-tn
253 :disp (frame-byte-offset
258 (inst lea rbp-tn (make-ea :qword :base rsp-tn
259 :disp (frame-byte-offset
263 (inst mov rcx (fixnumize 2))
264 (inst call (make-ea :qword
265 :disp (+ nil-value (static-fun-offset 'eql))))
272 (define-vop (generic-eql)
276 (:args (x :scs (descriptor-reg any-reg) :target rdx)
277 (y :scs (descriptor-reg any-reg) :target rdi))
279 (:temporary (:sc unsigned-reg :offset rdx-offset
282 (:temporary (:sc unsigned-reg :offset rdi-offset
286 (:temporary (:sc unsigned-reg :offset rcx-offset
293 (inst mov rcx (make-fixup 'generic-eql :assembly-routine))
297 (define-assembly-routine (generic-=
298 (:return-style :none))
299 ((:arg x (descriptor-reg any-reg) rdx-offset)
300 (:arg y (descriptor-reg any-reg) rdi-offset)
302 (:temp rcx unsigned-reg rcx-offset))
305 (inst test rcx fixnum-tag-mask)
306 (inst jmp :nz DO-STATIC-FUN)
314 (inst mov rbp-tn rsp-tn)
315 (inst sub rsp-tn (* n-word-bytes 3))
316 (inst mov (make-ea :qword :base rsp-tn
317 :disp (frame-byte-offset
322 (inst lea rbp-tn (make-ea :qword :base rsp-tn
323 :disp (frame-byte-offset
328 (inst mov rcx (fixnumize 2))
329 (inst call (make-ea :qword
330 :disp (+ nil-value (static-fun-offset 'two-arg-=))))
337 (define-vop (generic-=)
341 (:args (x :scs (descriptor-reg any-reg) :target rdx)
342 (y :scs (descriptor-reg any-reg) :target rdi))
344 (:temporary (:sc unsigned-reg :offset rdx-offset
347 (:temporary (:sc unsigned-reg :offset rdi-offset
351 (:temporary (:sc unsigned-reg :offset rcx-offset
358 (inst mov rcx (make-fixup 'generic-= :assembly-routine))