Closes https://bugs.launchpad.net/sbcl/+bug/911027
[sbcl.git] / src / assembly / ppc / arith.lisp
1 (in-package "SB!VM")
2
3
4 \f
5 ;;;; Addition and subtraction.
6
7 ;;; static-fun-offset returns the address of the raw_addr slot of
8 ;;; a static function's fdefn.
9
10 ;;; Note that there is only one use of static-fun-offset outside this
11 ;;; file (in genesis.lisp)
12
13 (define-assembly-routine
14   (generic-+
15    (:cost 10)
16    (:return-style :full-call)
17    (:translate +)
18    (:policy :safe)
19    (:save-p t))
20   ((:arg x (descriptor-reg any-reg) a0-offset)
21    (:arg y (descriptor-reg any-reg) a1-offset)
22
23    (:res res (descriptor-reg any-reg) a0-offset)
24
25    (:temp temp non-descriptor-reg nl0-offset)
26    (:temp temp2 non-descriptor-reg nl1-offset)
27    (:temp flag non-descriptor-reg nl3-offset)
28    (:temp lra descriptor-reg lra-offset)
29    (:temp nargs any-reg nargs-offset)
30    (:temp lip interior-reg lip-offset)
31    (:temp ocfp any-reg ocfp-offset))
32
33   ; Clear the damned "sticky overflow" bit in :cr0 and :xer
34   (inst mtxer zero-tn)
35   (inst or temp x y)
36   (inst andi. temp temp 3)
37   (inst bne DO-STATIC-FUN)
38   (inst addo. temp x y)
39   (inst bns done)
40
41   (inst srawi temp x 2)
42   (inst srawi temp2 y 2)
43   (inst add temp2 temp2 temp)
44   (with-fixed-allocation (res flag temp bignum-widetag (1+ bignum-digits-offset))
45     (storew temp2 res bignum-digits-offset other-pointer-lowtag))
46   (lisp-return lra lip :offset 2)
47
48   DO-STATIC-FUN
49   (inst addi lexenv-tn null-tn (static-fdefn-offset 'two-arg-+))
50   (loadw code-tn lexenv-tn fdefn-fun-slot other-pointer-lowtag)
51   (loadw lip lexenv-tn fdefn-raw-addr-slot other-pointer-lowtag)
52   (inst li nargs (fixnumize 2))
53   (inst mr ocfp cfp-tn)
54   (inst mr cfp-tn csp-tn)
55   (inst j lip 0)
56
57   DONE
58   (move res temp))
59
60
61 (define-assembly-routine
62   (generic--
63    (:cost 10)
64    (:return-style :full-call)
65    (:translate -)
66    (:policy :safe)
67    (:save-p t))
68   ((:arg x (descriptor-reg any-reg) a0-offset)
69    (:arg y (descriptor-reg any-reg) a1-offset)
70
71    (:res res (descriptor-reg any-reg) a0-offset)
72
73    (:temp temp non-descriptor-reg nl0-offset)
74    (:temp temp2 non-descriptor-reg nl1-offset)
75    (:temp flag non-descriptor-reg nl3-offset)
76    (:temp lip interior-reg lip-offset)
77    (:temp lra descriptor-reg lra-offset)
78    (:temp nargs any-reg nargs-offset)
79    (:temp ocfp any-reg ocfp-offset))
80
81   ; Clear the damned "sticky overflow" bit in :cr0
82   (inst mtxer zero-tn)
83
84   (inst or temp x y)
85   (inst andi. temp temp 3)
86   (inst bne DO-STATIC-FUN)
87
88   (inst subo. temp x y)
89   (inst bns done)
90
91   (inst srawi temp x 2)
92   (inst srawi temp2 y 2)
93   (inst sub temp2 temp temp2)
94   (with-fixed-allocation (res flag temp bignum-widetag (1+ bignum-digits-offset))
95     (storew temp2 res bignum-digits-offset other-pointer-lowtag))
96   (lisp-return lra lip :offset 2)
97
98   DO-STATIC-FUN
99   (inst addi lexenv-tn null-tn (static-fdefn-offset 'two-arg--))
100   (loadw code-tn lexenv-tn fdefn-fun-slot other-pointer-lowtag)
101   (loadw lip lexenv-tn fdefn-raw-addr-slot other-pointer-lowtag)
102   (inst li nargs (fixnumize 2))
103   (inst mr ocfp cfp-tn)
104   (inst mr cfp-tn csp-tn)
105   (inst j lip 0)
106
107   DONE
108   (move res temp))
109
110
111 \f
112 ;;;; Multiplication
113
114
115 (define-assembly-routine
116   (generic-*
117    (:cost 50)
118    (:return-style :full-call)
119    (:translate *)
120    (:policy :safe)
121    (:save-p t))
122   ((:arg x (descriptor-reg any-reg) a0-offset)
123    (:arg y (descriptor-reg any-reg) a1-offset)
124
125    (:res res (descriptor-reg any-reg) a0-offset)
126
127    (:temp temp non-descriptor-reg nl0-offset)
128    (:temp lo non-descriptor-reg nl1-offset)
129    (:temp hi non-descriptor-reg nl2-offset)
130    (:temp pa-flag non-descriptor-reg nl3-offset)
131    (:temp lip interior-reg lip-offset)
132    (:temp lra descriptor-reg lra-offset)
133    (:temp nargs any-reg nargs-offset)
134    (:temp ocfp any-reg ocfp-offset))
135
136   ;; If either arg is not a fixnum, call the static function.  But first ...
137   (inst mtxer zero-tn)
138
139   (inst or temp x y)
140   (inst andi. temp temp 3)
141   ;; Remove the tag from both args, so I don't get so confused.
142   (inst srawi temp x 2)
143   (inst srawi nargs y 2)
144   (inst bne DO-STATIC-FUN)
145
146
147   (inst mullwo. lo nargs temp)
148   (inst srawi hi lo 31)                 ; hi = 32 copies of lo's sign bit
149   (inst bns ONE-WORD-ANSWER)
150   (inst mulhw hi nargs temp)
151   (inst b CONS-BIGNUM)
152
153   ONE-WORD-ANSWER                       ; We know that all of the overflow bits are clear.
154   (inst addo temp lo lo)
155   (inst addo. res temp temp)
156   (inst bns GO-HOME)
157
158   CONS-BIGNUM
159   ;; Allocate a BIGNUM for the result.
160   (with-fixed-allocation (res pa-flag temp bignum-widetag
161                               (+ bignum-digits-offset 2))
162     (let ((one-word (gen-label)))
163       ;; We start out assuming that we need one word.  Is that correct?
164       (inst srawi temp lo 31)
165       (inst xor. temp temp hi)
166       (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
167       (inst beq one-word)
168       (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
169       (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
170       (emit-label one-word)
171       (storew temp res 0 other-pointer-lowtag)
172       (storew lo res bignum-digits-offset other-pointer-lowtag)))
173   ;; Out of here
174   GO-HOME
175   (lisp-return lra lip :offset 2)
176
177   DO-STATIC-FUN
178   (inst addi lexenv-tn null-tn (static-fdefn-offset 'two-arg-*))
179   (loadw code-tn lexenv-tn fdefn-fun-slot other-pointer-lowtag)
180   (loadw lip lexenv-tn fdefn-raw-addr-slot other-pointer-lowtag)
181   (inst li nargs (fixnumize 2))
182   (inst mr ocfp cfp-tn)
183   (inst mr cfp-tn csp-tn)
184   (inst j lip 0)
185
186   LOW-FITS-IN-FIXNUM
187   (move res lo))
188
189 (macrolet
190     ((frob (name note cost type sc)
191        `(define-assembly-routine (,name
192                                   (:note ,note)
193                                   (:cost ,cost)
194                                   (:translate *)
195                                   (:policy :fast-safe)
196                                   (:arg-types ,type ,type)
197                                   (:result-types ,type))
198                                  ((:arg x ,sc nl0-offset)
199                                   (:arg y ,sc nl1-offset)
200                                   (:res res ,sc nl0-offset))
201           ,@(when (eq type 'tagged-num)
202               `((inst srawi x x 2)))
203           (inst mullw res x y))))
204   (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg)
205   (frob signed-* "signed *" 41 signed-num signed-reg)
206   (frob fixnum-* "fixnum *" 30 tagged-num any-reg))
207
208
209 \f
210 ;;;; Division.
211
212
213 (define-assembly-routine (positive-fixnum-truncate
214                           (:note "unsigned fixnum truncate")
215                           (:cost 45)
216                           (:translate truncate)
217                           (:policy :fast-safe)
218                           (:arg-types positive-fixnum positive-fixnum)
219                           (:result-types positive-fixnum positive-fixnum))
220                          ((:arg dividend any-reg nl0-offset)
221                           (:arg divisor any-reg nl1-offset)
222
223                           (:res quo any-reg nl2-offset)
224                           (:res rem any-reg nl0-offset))
225   (aver (location= rem dividend))
226   (let ((error (generate-error-code nil 'division-by-zero-error
227                                     dividend divisor)))
228     (inst cmpwi divisor 0)
229     (inst beq error))
230     (inst divwu quo dividend divisor)
231     (inst mullw divisor quo divisor)
232     (inst sub rem dividend divisor)
233     (inst slwi quo quo 2))
234
235
236
237 (define-assembly-routine (fixnum-truncate
238                           (:note "fixnum truncate")
239                           (:cost 50)
240                           (:policy :fast-safe)
241                           (:translate truncate)
242                           (:arg-types tagged-num tagged-num)
243                           (:result-types tagged-num tagged-num))
244                          ((:arg dividend any-reg nl0-offset)
245                           (:arg divisor any-reg nl1-offset)
246
247                           (:res quo any-reg nl2-offset)
248                           (:res rem any-reg nl0-offset))
249
250   (aver (location= rem dividend))
251   (let ((error (generate-error-code nil 'division-by-zero-error
252                                     dividend divisor)))
253     (inst cmpwi divisor 0)
254     (inst beq error))
255
256     (inst divw quo dividend divisor)
257     (inst mullw divisor quo divisor)
258     (inst subf rem divisor dividend)
259     (inst slwi quo quo 2))
260
261
262 (define-assembly-routine (signed-truncate
263                           (:note "(signed-byte 32) truncate")
264                           (:cost 60)
265                           (:policy :fast-safe)
266                           (:translate truncate)
267                           (:arg-types signed-num signed-num)
268                           (:result-types signed-num signed-num))
269
270                          ((:arg dividend signed-reg nl0-offset)
271                           (:arg divisor signed-reg nl1-offset)
272
273                           (:res quo signed-reg nl2-offset)
274                           (:res rem signed-reg nl0-offset))
275
276   (let ((error (generate-error-code nil 'division-by-zero-error
277                                     dividend divisor)))
278     (inst cmpwi divisor 0)
279     (inst beq error))
280
281     (inst divw quo dividend divisor)
282     (inst mullw divisor quo divisor)
283     (inst subf rem divisor dividend))
284
285 \f
286 ;;;; Comparison
287
288 (macrolet
289     ((define-cond-assem-rtn (name translate static-fn cmp)
290        `(define-assembly-routine
291           (,name
292            (:cost 10)
293            (:return-style :full-call)
294            (:policy :safe)
295            (:translate ,translate)
296            (:save-p t))
297           ((:arg x (descriptor-reg any-reg) a0-offset)
298            (:arg y (descriptor-reg any-reg) a1-offset)
299
300            (:res res descriptor-reg a0-offset)
301
302            (:temp lip interior-reg lip-offset)
303            (:temp nargs any-reg nargs-offset)
304            (:temp ocfp any-reg ocfp-offset))
305
306           (inst or nargs x y)
307           (inst andi. nargs nargs 3)
308           (inst cmpw :cr1 x y)
309           (inst beq DO-COMPARE)
310
311           DO-STATIC-FN
312           (inst addi lexenv-tn null-tn (static-fdefn-offset ',static-fn))
313           (loadw code-tn lexenv-tn fdefn-fun-slot other-pointer-lowtag)
314           (loadw lip lexenv-tn fdefn-raw-addr-slot other-pointer-lowtag)
315           (inst li nargs (fixnumize 2))
316           (inst mr ocfp cfp-tn)
317           (inst mr cfp-tn csp-tn)
318           (inst j lip 0)
319
320           DO-COMPARE
321           (load-symbol res t)
322           (inst b? :cr1 ,cmp done)
323           (inst mr res null-tn)
324           DONE)))
325
326   (define-cond-assem-rtn generic-< < two-arg-< :lt)
327   (define-cond-assem-rtn generic-<= <= two-arg-<= :le)
328   (define-cond-assem-rtn generic-> > two-arg-> :gt)
329   (define-cond-assem-rtn generic->= >= two-arg->= :ge))
330
331
332 (define-assembly-routine (generic-eql
333                           (:cost 10)
334                           (:return-style :full-call)
335                           (:policy :safe)
336                           (:translate eql)
337                           (:save-p t))
338                          ((:arg x (descriptor-reg any-reg) a0-offset)
339                           (:arg y (descriptor-reg any-reg) a1-offset)
340
341                           (:res res descriptor-reg a0-offset)
342
343                           (:temp lra descriptor-reg lra-offset)
344                           (:temp lip interior-reg lip-offset)
345                           (:temp nargs any-reg nargs-offset)
346                           (:temp ocfp any-reg ocfp-offset))
347   (inst cmpw :cr1 x y)
348   (inst andi. nargs x 3)
349   (inst beq :cr1 RETURN-T)
350   (inst beq RETURN-NIL)                 ; x was fixnum, not eq y
351   (inst andi. nargs y 3)
352   (inst bne DO-STATIC-FN)
353
354   RETURN-NIL
355   (inst mr res null-tn)
356   (lisp-return lra lip :offset 2)
357
358   DO-STATIC-FN
359   (inst addi lexenv-tn null-tn (static-fdefn-offset 'eql))
360   (loadw code-tn lexenv-tn fdefn-fun-slot other-pointer-lowtag)
361   (loadw lip lexenv-tn fdefn-raw-addr-slot other-pointer-lowtag)
362   (inst li nargs (fixnumize 2))
363   (inst mr ocfp cfp-tn)
364   (inst mr cfp-tn csp-tn)
365   (inst j lip 0)
366
367   RETURN-T
368   (load-symbol res t))
369
370 (define-assembly-routine
371   (generic-=
372    (:cost 10)
373    (:return-style :full-call)
374    (:policy :safe)
375    (:translate =)
376    (:save-p t))
377   ((:arg x (descriptor-reg any-reg) a0-offset)
378    (:arg y (descriptor-reg any-reg) a1-offset)
379
380    (:res res descriptor-reg a0-offset)
381
382    (:temp lip interior-reg lip-offset)
383    (:temp lra descriptor-reg lra-offset)
384    (:temp nargs any-reg nargs-offset)
385    (:temp ocfp any-reg ocfp-offset))
386
387   (inst or nargs x y)
388   (inst andi. nargs nargs 3)
389   (inst cmpw :cr1 x y)
390   (inst bne DO-STATIC-FN)
391   (inst beq :cr1 RETURN-T)
392
393   (inst mr res null-tn)
394   (lisp-return lra lip :offset 2)
395
396   DO-STATIC-FN
397   (inst addi lexenv-tn null-tn (static-fdefn-offset 'two-arg-=))
398   (loadw code-tn lexenv-tn fdefn-fun-slot other-pointer-lowtag)
399   (loadw lip lexenv-tn fdefn-raw-addr-slot other-pointer-lowtag)
400   (inst li nargs (fixnumize 2))
401   (inst mr ocfp cfp-tn)
402   (inst mr cfp-tn csp-tn)
403   (inst j lip 0)
404
405   RETURN-T
406   (load-symbol res t))
407
408 (define-assembly-routine (generic-/=
409                           (:cost 10)
410                           (:return-style :full-call)
411                           (:policy :safe)
412                           (:translate /=)
413                           (:save-p t))
414                          ((:arg x (descriptor-reg any-reg) a0-offset)
415                           (:arg y (descriptor-reg any-reg) a1-offset)
416
417                           (:res res descriptor-reg a0-offset)
418
419                           (:temp lra descriptor-reg lra-offset)
420                           (:temp lip interior-reg lip-offset)
421
422                           (:temp nargs any-reg nargs-offset)
423                           (:temp ocfp any-reg ocfp-offset))
424   (inst or nargs x y)
425   (inst andi. nargs nargs 3)
426   (inst cmpw :cr1 x y)
427   (inst bne DO-STATIC-FN)
428   (inst beq :cr1 RETURN-NIL)
429
430   (load-symbol res t)
431   (lisp-return lra lip :offset 2)
432
433   DO-STATIC-FN
434   (inst addi lexenv-tn null-tn (static-fdefn-offset 'two-arg-/=))
435   (loadw code-tn lexenv-tn fdefn-fun-slot other-pointer-lowtag)
436   (loadw lip lexenv-tn fdefn-raw-addr-slot other-pointer-lowtag)
437   (inst li nargs (fixnumize 2))
438   (inst mr ocfp cfp-tn)
439   (inst j lip 0)
440   (inst mr cfp-tn csp-tn)
441
442   RETURN-NIL
443   (inst mr res null-tn))