fix bug in SYMBOL-VALUE CAS expansion for constant arguments
[sbcl.git] / src / assembly / x86-64 / arith.lisp
1 ;;;; simple cases for generic arithmetic
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!VM")
13 \f
14 ;;;; addition, subtraction, and multiplication
15
16 (macrolet ((define-generic-arith-routine ((fun cost) &body body)
17              `(define-assembly-routine (,(symbolicate "GENERIC-" fun)
18                                         (:cost ,cost)
19                                         (:return-style :full-call)
20                                         (:translate ,fun)
21                                         (:policy :safe)
22                                         (:save-p t))
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?
26                        rdi-offset)
27
28                  (:res res (descriptor-reg any-reg) rdx-offset)
29
30                  (:temp rax unsigned-reg rax-offset)
31                  (:temp rcx unsigned-reg rcx-offset))
32
33                 (inst mov rcx x)
34                 (inst or rcx y)
35                 (inst test rcx fixnum-tag-mask) ; both fixnums?
36                 (inst jmp :nz DO-STATIC-FUN)    ; no - do generic
37
38                 ,@body
39                 (inst clc) ; single-value return
40                 (inst ret)
41
42                 DO-STATIC-FUN
43                 ;; Same as: (inst enter (* n-word-bytes 1))
44                 (inst push rbp-tn)
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
50                 (inst jmp
51                       (make-ea :qword
52                                :disp (+ nil-value
53                                         (static-fun-offset
54                                          ',(symbolicate "TWO-ARG-" fun))))))))
55
56   #.`
57   (define-generic-arith-routine (+ 10)
58     (move res x)
59     (inst add res y)
60     (inst jmp :no OKAY)
61     ;; Unbox the overflowed result, recovering the correct sign from
62     ;; the carry flag, then re-box as a bignum.
63     (inst rcr res 1)
64     ,@(when (> n-fixnum-tag-bits 1)   ; don't shift by 0
65             '((inst sar res (1- n-fixnum-tag-bits))))
66
67     (move rcx res)
68
69     (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
70       (storew rcx res bignum-digits-offset other-pointer-lowtag))
71
72     OKAY)
73
74   #.`
75   (define-generic-arith-routine (- 10)
76     (move res x)
77     (inst sub res y)
78     (inst jmp :no OKAY)
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
82     (inst rcr res 1)
83     ,@(when (> n-fixnum-tag-bits 1)   ; don't shift by 0
84             '((inst sar res (1- n-fixnum-tag-bits))))
85
86     (move rcx res)
87
88     (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
89       (storew rcx res bignum-digits-offset other-pointer-lowtag))
90     OKAY)
91
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
97
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
100
101     (move rcx x)                   ; save high bits from cqo
102     (inst cqo)                     ; edx:eax <- sign-extend of eax
103     (inst cmp x rcx)
104     (inst jmp :e SINGLE-WORD-BIGNUM)
105
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))
109     (inst jmp DONE)
110
111     SINGLE-WORD-BIGNUM
112
113     (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
114       (storew rax res bignum-digits-offset other-pointer-lowtag))
115     (inst jmp DONE)
116
117     OKAY
118     (move res rax)
119     DONE))
120 \f
121 ;;;; negation
122
123 (define-assembly-routine (generic-negate
124                           (:cost 10)
125                           (:return-style :full-call)
126                           (:policy :safe)
127                           (:translate %negate)
128                           (:save-p t))
129                          ((:arg x (descriptor-reg any-reg) rdx-offset)
130                           (:res res (descriptor-reg any-reg) rdx-offset)
131
132                           (:temp rax unsigned-reg rax-offset)
133                           (:temp rcx unsigned-reg rcx-offset))
134   (inst test x fixnum-tag-mask)
135   (inst jmp :z FIXNUM)
136
137   (inst push rbp-tn)
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))))
145
146   FIXNUM
147   (move res x)
148   (inst neg res)                        ; (- most-negative-fixnum) is BIGNUM
149   (inst jmp :no OKAY)
150   (inst shr res n-fixnum-tag-bits)      ; sign bit is data - remove type bits
151   (move rcx res)
152
153   (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
154     (storew rcx res bignum-digits-offset other-pointer-lowtag))
155
156   OKAY)
157 \f
158 ;;;; comparison
159
160 (macrolet ((define-cond-assem-rtn (name translate static-fn test)
161                (declare (ignorable translate static-fn))
162              #+sb-assembling
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)
167
168                    (:temp rcx unsigned-reg rcx-offset))
169
170                 (inst mov rcx x)
171                 (inst or rcx y)
172                 (inst test rcx fixnum-tag-mask)
173                 (inst jmp :nz DO-STATIC-FUN)  ; are both fixnums?
174
175                 (inst cmp x y)
176                 (inst ret)
177
178                 DO-STATIC-FUN
179                 (inst sub rsp-tn (* n-word-bytes 3))
180                 (inst mov (make-ea :qword :base rsp-tn
181                                    :disp (frame-byte-offset
182                                           (+ sp->fp-offset
183                                              -3
184                                              ocfp-save-offset)))
185                       rbp-tn)
186                 (inst lea rbp-tn (make-ea :qword :base rsp-tn
187                                           :disp (frame-byte-offset
188                                           (+ sp->fp-offset
189                                              -3
190                                              ocfp-save-offset))))
191                 (inst mov rcx (fixnumize 2))
192                 (inst call (make-ea :qword
193                                     :disp (+ nil-value
194                                              (static-fun-offset ',static-fn))))
195                 ;; HACK: We depend on NIL having the lowest address of all
196                 ;; static symbols (including T)
197                 ,@(ecase test
198                     (:l `((inst mov y (1+ nil-value))
199                           (inst cmp y x)))
200                     (:g `((inst cmp x (1+ nil-value)))))
201                 (inst ret))
202              #-sb-assembling
203              `(define-vop (,name)
204                 (:translate ,translate)
205                 (:policy :safe)
206                 (:save-p t)
207                 (:args (x :scs (descriptor-reg any-reg) :target rdx)
208                        (y :scs (descriptor-reg any-reg) :target rdi))
209
210                 (:temporary (:sc unsigned-reg :offset rdx-offset
211                                  :from (:argument 0))
212                             rdx)
213                 (:temporary (:sc unsigned-reg :offset rdi-offset
214                                  :from (:argument 1))
215                             rdi)
216
217                 (:temporary (:sc unsigned-reg :offset rcx-offset
218                                  :from :eval)
219                             rcx)
220                 (:conditional ,test)
221                 (:generator 10
222                    (move rdx x)
223                    (move rdi y)
224                    (inst lea rcx (make-ea :qword
225                                           :disp (make-fixup ',name :assembly-routine)))
226                    (inst call rcx)))))
227
228   (define-cond-assem-rtn generic-< < two-arg-< :l)
229   (define-cond-assem-rtn generic-> > two-arg-> :g))
230
231 #+sb-assembling
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)
236
237                           (:temp rcx unsigned-reg rcx-offset))
238
239   (inst mov rcx x)
240   (inst and rcx y)
241   (inst test rcx fixnum-tag-mask)
242   (inst jmp :nz DO-STATIC-FUN)
243
244   ;; At least one fixnum
245   (inst cmp x y)
246   (inst ret)
247
248   DO-STATIC-FUN
249   (inst sub rsp-tn (* n-word-bytes 3))
250   (inst mov (make-ea :qword :base rsp-tn
251                      :disp (frame-byte-offset
252                             (+ sp->fp-offset
253                                -3
254                                ocfp-save-offset)))
255         rbp-tn)
256   (inst lea rbp-tn (make-ea :qword :base rsp-tn
257                             :disp (frame-byte-offset
258                                    (+ sp->fp-offset
259                                       -3
260                                       ocfp-save-offset))))
261   (inst mov rcx (fixnumize 2))
262   (inst call (make-ea :qword
263                       :disp (+ nil-value (static-fun-offset 'eql))))
264   (load-symbol y t)
265   (inst cmp x y)
266   (inst ret))
267
268 #-sb-assembling
269 (define-vop (generic-eql)
270   (:translate eql)
271   (:policy :safe)
272   (:save-p t)
273   (:args (x :scs (descriptor-reg any-reg) :target rdx)
274          (y :scs (descriptor-reg any-reg) :target rdi))
275
276   (:temporary (:sc unsigned-reg :offset rdx-offset
277                :from (:argument 0))
278               rdx)
279   (:temporary (:sc unsigned-reg :offset rdi-offset
280                :from (:argument 1))
281               rdi)
282
283   (:temporary (:sc unsigned-reg :offset rcx-offset
284                :from :eval)
285               rcx)
286   (:conditional :e)
287   (:generator 10
288     (move rdx x)
289     (move rdi y)
290     (inst lea rcx (make-ea :qword
291                            :disp (make-fixup 'generic-eql :assembly-routine)))
292     (inst call rcx)))
293
294 #+sb-assembling
295 (define-assembly-routine (generic-=
296                           (:return-style :none))
297                          ((:arg x (descriptor-reg any-reg) rdx-offset)
298                           (:arg y (descriptor-reg any-reg) rdi-offset)
299
300                           (:temp rcx unsigned-reg rcx-offset))
301   (inst mov rcx x)
302   (inst or rcx y)
303   (inst test rcx fixnum-tag-mask)
304   (inst jmp :nz DO-STATIC-FUN)
305
306   ;; Both fixnums
307   (inst cmp x y)
308   (inst ret)
309
310   DO-STATIC-FUN
311   (inst sub rsp-tn (* n-word-bytes 3))
312   (inst mov (make-ea :qword :base rsp-tn
313                      :disp (frame-byte-offset
314                             (+ sp->fp-offset
315                                -3
316                                ocfp-save-offset)))
317         rbp-tn)
318   (inst lea rbp-tn (make-ea :qword :base rsp-tn
319                             :disp (frame-byte-offset
320                                    (+ sp->fp-offset
321                                       -3
322                                       ocfp-save-offset))))
323
324   (inst mov rcx (fixnumize 2))
325   (inst call (make-ea :qword
326                       :disp (+ nil-value (static-fun-offset 'two-arg-=))))
327   (load-symbol y t)
328   (inst cmp x y)
329   (inst ret))
330
331 #-sb-assembling
332 (define-vop (generic-=)
333   (:translate =)
334   (:policy :safe)
335   (:save-p t)
336   (:args (x :scs (descriptor-reg any-reg) :target rdx)
337          (y :scs (descriptor-reg any-reg) :target rdi))
338
339   (:temporary (:sc unsigned-reg :offset rdx-offset
340                :from (:argument 0))
341               rdx)
342   (:temporary (:sc unsigned-reg :offset rdi-offset
343                :from (:argument 1))
344               rdi)
345
346   (:temporary (:sc unsigned-reg :offset rcx-offset
347                :from :eval)
348               rcx)
349   (:conditional :e)
350   (:generator 10
351     (move rdx x)
352     (move rdi y)
353     (inst lea rcx (make-ea :qword
354                            :disp (make-fixup 'generic-= :assembly-routine)))
355     (inst call rcx)))