1.0.1.10:
[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 rbx unsigned-reg rbx-offset)
32                  (:temp rcx unsigned-reg rcx-offset))
33
34                 (declare (ignorable rbx))
35
36                 (inst test x 7)  ; fixnum?
37                 (inst jmp :nz DO-STATIC-FUN) ; no - do generic
38                 (inst test y 7)  ; fixnum?
39                 (inst jmp :z DO-BODY)   ; yes - doit here
40
41                 DO-STATIC-FUN
42                 (inst pop rax)
43                 (inst push rbp-tn)
44                 (inst lea
45                       rbp-tn
46                       (make-ea :qword :base rsp-tn :disp n-word-bytes))
47                 (inst sub rsp-tn (fixnumize 2))
48                 (inst push rax)  ; callers return addr
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                 DO-BODY
57                 ,@body)))
58
59   (define-generic-arith-routine (+ 10)
60     (move res x)
61     (inst add res y)
62     (inst jmp :no OKAY)
63     (inst rcr res 1)                  ; carry has correct sign
64     (inst sar res 2)                  ; remove type bits
65
66     (move rcx res)
67
68     (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
69       (storew rcx res bignum-digits-offset other-pointer-lowtag))
70
71     OKAY)
72
73   (define-generic-arith-routine (- 10)
74     (move res x)
75     (inst sub res y)
76     (inst jmp :no OKAY)
77     (inst cmc)                        ; carry has correct sign now
78     (inst rcr res 1)
79     (inst sar res 2)                  ; remove type bits
80
81     (move rcx res)
82
83     (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
84       (storew rcx res bignum-digits-offset other-pointer-lowtag))
85     OKAY)
86
87   (define-generic-arith-routine (* 30)
88     (move rax x)                   ; must use eax for 64-bit result
89     (inst sar rax 3)               ; remove *4 fixnum bias
90     (inst imul y)                  ; result in edx:eax
91     (inst jmp :no OKAY)            ; still fixnum
92
93     ;; zzz jrd changed edx to ebx in here, as edx isn't listed as a temp, above
94     ;;     pfw says that loses big -- edx is target for arg x and result res
95     ;;     note that 'edx' is not defined -- using x
96     (inst shrd rax x 3)            ; high bits from edx
97     (inst sar x 3)                 ; now shift edx too
98
99     (move rcx x)                   ; save high bits from cqo
100     (inst cqo)                     ; edx:eax <- sign-extend of eax
101     (inst cmp x rcx)
102     (inst jmp :e SINGLE-WORD-BIGNUM)
103
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))
107     (inst jmp DONE)
108
109     SINGLE-WORD-BIGNUM
110
111     (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
112       (storew rax res bignum-digits-offset other-pointer-lowtag))
113     (inst jmp DONE)
114
115     OKAY
116     (move res rax)
117     DONE))
118 \f
119 ;;;; negation
120
121 (define-assembly-routine (generic-negate
122                           (:cost 10)
123                           (:return-style :full-call)
124                           (:policy :safe)
125                           (:translate %negate)
126                           (:save-p t))
127                          ((:arg x (descriptor-reg any-reg) rdx-offset)
128                           (:res res (descriptor-reg any-reg) rdx-offset)
129
130                           (:temp rax unsigned-reg rax-offset)
131                           (:temp rcx unsigned-reg rcx-offset))
132   (inst test x 7)
133   (inst jmp :z FIXNUM)
134
135   (inst pop rax)
136   (inst push rbp-tn)
137   (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes))
138   (inst sub rsp-tn (fixnumize 2))
139   (inst push rax)
140   (inst mov rcx (fixnumize 1))    ; arg count
141   (inst jmp (make-ea :qword
142                      :disp (+ nil-value (static-fun-offset '%negate))))
143
144   FIXNUM
145   (move res x)
146   (inst neg res)                        ; (- most-negative-fixnum) is BIGNUM
147   (inst jmp :no OKAY)
148   (inst shr res 3)                    ; sign bit is data - remove type bits
149   (move rcx res)
150
151   (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
152     (storew rcx res bignum-digits-offset other-pointer-lowtag))
153
154   OKAY)
155 \f
156 ;;;; comparison
157
158 (macrolet ((define-cond-assem-rtn (name translate static-fn test)
159              `(define-assembly-routine (,name
160                                         (:cost 10)
161                                         (:return-style :full-call)
162                                         (:policy :safe)
163                                         (:translate ,translate)
164                                         (:save-p t))
165                 ((:arg x (descriptor-reg any-reg) rdx-offset)
166                  (:arg y (descriptor-reg any-reg) rdi-offset)
167
168                  (:res res descriptor-reg rdx-offset)
169
170                  (:temp eax unsigned-reg rax-offset)
171                  (:temp ecx unsigned-reg rcx-offset))
172
173                 ;; KLUDGE: The "3" here is a mask for the bits which will be
174                 ;; zero in a fixnum. It should have a symbolic name. (Actually,
175                 ;; it might already have a symbolic name which the coder
176                 ;; couldn't be bothered to use..) -- WHN 19990917
177                 (inst test x 7)
178                 (inst jmp :nz TAIL-CALL-TO-STATIC-FN)
179                 (inst test y 7)
180                 (inst jmp :z INLINE-FIXNUM-COMPARE)
181
182                 TAIL-CALL-TO-STATIC-FN
183                 (inst pop eax)
184                 (inst push rbp-tn)
185                 (inst lea rbp-tn (make-ea :qword
186                                           :base rsp-tn
187                                           :disp n-word-bytes))
188                 (inst sub rsp-tn (fixnumize 2)) ; FIXME: Push 2 words on stack,
189                                                 ; weirdly?
190                 (inst push eax)
191                 (inst mov ecx (fixnumize 2)) ; FIXME: FIXNUMIZE and
192                                         ; SINGLE-FLOAT-BITS are parallel,
193                                         ; should be named parallelly.
194                 (inst jmp (make-ea :qword
195                                    :disp (+ nil-value
196                                             (static-fun-offset ',static-fn))))
197
198                 INLINE-FIXNUM-COMPARE
199                 (inst cmp x y)
200                 (inst mov res nil-value)
201                 (inst jmp ,test RETURN-FALSE)
202                 RETURN-TRUE
203                 (load-symbol res t)
204                 RETURN-FALSE
205                 DONE)))
206
207   (define-cond-assem-rtn generic-< < two-arg-< :ge)
208   (define-cond-assem-rtn generic-> > two-arg-> :le))
209
210 (define-assembly-routine (generic-eql
211                           (:cost 10)
212                           (:return-style :full-call)
213                           (:policy :safe)
214                           (:translate eql)
215                           (:save-p t))
216                          ((:arg x (descriptor-reg any-reg) rdx-offset)
217                           (:arg y (descriptor-reg any-reg) rdi-offset)
218
219                           (:res res descriptor-reg rdx-offset)
220
221                           (:temp eax unsigned-reg rax-offset)
222                           (:temp ecx unsigned-reg rcx-offset))
223   (inst cmp x y)
224   (inst jmp :e RETURN-T)
225   (inst test x 7)
226   (inst jmp :z RETURN-NIL)
227   (inst test y 7)
228   (inst jmp :nz DO-STATIC-FN)
229
230   RETURN-NIL
231   (inst mov res nil-value)
232   (inst jmp DONE)
233
234   DO-STATIC-FN
235   (inst pop eax)
236   (inst push rbp-tn)
237   (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes))
238   (inst sub rsp-tn (fixnumize 2))
239   (inst push eax)
240   (inst mov ecx (fixnumize 2))
241   (inst jmp (make-ea :qword
242                      :disp (+ nil-value (static-fun-offset 'eql))))
243
244   RETURN-T
245   (load-symbol res t)
246   DONE)
247
248 (define-assembly-routine (generic-=
249                           (:cost 10)
250                           (:return-style :full-call)
251                           (:policy :safe)
252                           (:translate =)
253                           (:save-p t))
254                          ((:arg x (descriptor-reg any-reg) rdx-offset)
255                           (:arg y (descriptor-reg any-reg) rdi-offset)
256
257                           (:res res descriptor-reg rdx-offset)
258
259                           (:temp eax unsigned-reg rax-offset)
260                           (:temp ecx unsigned-reg rcx-offset)
261                           )
262   (inst test x 7)                      ; descriptor?
263   (inst jmp :nz DO-STATIC-FN)          ; yes, do it here
264   (inst test y 7)                      ; descriptor?
265   (inst jmp :nz DO-STATIC-FN)
266   (inst cmp x y)
267   (inst jmp :e RETURN-T)                ; ok
268
269   (inst mov res nil-value)
270   (inst jmp DONE)
271
272   DO-STATIC-FN
273   (inst pop eax)
274   (inst push rbp-tn)
275   (inst lea rbp-tn (make-ea :qword :base rsp-tn :disp n-word-bytes))
276   (inst sub rsp-tn (fixnumize 2))
277   (inst push eax)
278   (inst mov ecx (fixnumize 2))
279   (inst jmp (make-ea :qword
280                      :disp (+ nil-value (static-fun-offset 'two-arg-=))))
281
282   RETURN-T
283   (load-symbol res t)
284   DONE)
285
286