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