0.8.12.16:
[sbcl.git] / src / assembly / sparc / arith.lisp
1 ;;;; Stuff to handle 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 and subtraction.
15
16 (define-assembly-routine (generic-+
17                           (:cost 10)
18                           (:return-style :full-call)
19                           (:translate +)
20                           (:policy :safe)
21                           (:save-p t))
22                          ((:arg x (descriptor-reg any-reg) a0-offset)
23                           (:arg y (descriptor-reg any-reg) a1-offset)
24
25                           (:res res (descriptor-reg any-reg) a0-offset)
26
27                           (:temp temp non-descriptor-reg nl0-offset)
28                           (:temp temp2 non-descriptor-reg nl1-offset)
29                           (:temp lra descriptor-reg lra-offset)
30                           (:temp nargs any-reg nargs-offset)
31                           (:temp ocfp any-reg ocfp-offset))
32   (inst andcc zero-tn x fixnum-tag-mask)
33   (inst b :ne DO-STATIC-FUN)
34   (inst andcc zero-tn y fixnum-tag-mask)
35   (inst b :ne DO-STATIC-FUN)
36   (inst nop)
37   (inst addcc temp x y)
38   (inst b :vc done)
39   (inst nop)
40
41   (inst sra temp x n-fixnum-tag-bits)
42   (inst sra temp2 y n-fixnum-tag-bits)
43   (inst add temp2 temp)
44   (with-fixed-allocation (res temp bignum-widetag (1+ bignum-digits-offset))
45     (storew temp2 res bignum-digits-offset other-pointer-lowtag))
46   (lisp-return lra :offset 2)
47
48   DO-STATIC-FUN
49   (inst ld code-tn null-tn (static-fun-offset 'two-arg-+))
50   (inst li nargs (fixnumize 2))
51   (inst move ocfp cfp-tn)
52   (inst j code-tn
53         (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
54   (inst move cfp-tn csp-tn)
55
56   DONE
57   (move res temp))
58
59
60 (define-assembly-routine (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 lra descriptor-reg lra-offset)
74                           (:temp nargs any-reg nargs-offset)
75                           (:temp ocfp any-reg ocfp-offset))
76   (inst andcc zero-tn x fixnum-tag-mask)
77   (inst b :ne DO-STATIC-FUN)
78   (inst andcc zero-tn y fixnum-tag-mask)
79   (inst b :ne DO-STATIC-FUN)
80   (inst nop)
81   (inst subcc temp x y)
82   (inst b :vc done)
83   (inst nop)
84
85   (inst sra temp x n-fixnum-tag-bits)
86   (inst sra temp2 y n-fixnum-tag-bits)
87   (inst sub temp2 temp temp2)
88   (with-fixed-allocation (res temp bignum-widetag (1+ bignum-digits-offset))
89     (storew temp2 res bignum-digits-offset other-pointer-lowtag))
90   (lisp-return lra :offset 2)
91
92   DO-STATIC-FUN
93   (inst ld code-tn null-tn (static-fun-offset 'two-arg--))
94   (inst li nargs (fixnumize 2))
95   (inst move ocfp cfp-tn)
96   (inst j code-tn
97         (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
98   (inst move cfp-tn csp-tn)
99
100   DONE
101   (move res temp))
102
103
104 \f
105 ;;;; Multiplication
106
107
108 (define-assembly-routine (generic-*
109                           (:cost 50)
110                           (:return-style :full-call)
111                           (:translate *)
112                           (:policy :safe)
113                           (:save-p t))
114                          ((:arg x (descriptor-reg any-reg) a0-offset)
115                           (:arg y (descriptor-reg any-reg) a1-offset)
116
117                           (:res res (descriptor-reg any-reg) a0-offset)
118
119                           (:temp temp non-descriptor-reg nl0-offset)
120                           (:temp lo non-descriptor-reg nl1-offset)
121                           (:temp hi non-descriptor-reg nl2-offset)
122                           (:temp lra descriptor-reg lra-offset)
123                           (:temp nargs any-reg nargs-offset)
124                           (:temp ocfp any-reg ocfp-offset))
125   ;; If either arg is not a fixnum, call the static function.
126   (inst andcc zero-tn x fixnum-tag-mask)
127   (inst b :ne DO-STATIC-FUN)
128   (inst andcc zero-tn y fixnum-tag-mask)
129   (inst b :ne DO-STATIC-FUN)
130   (inst nop)
131
132   ;; Remove the tag from one arg so that the result will have the correct
133   ;; fixnum tag.
134   (inst sra temp x n-fixnum-tag-bits)
135   ;; Compute the produce temp * y and return the double-word product
136   ;; in hi:lo.
137   (cond
138     ((member :sparc-64 *backend-subfeatures*)
139      ;; Sign extend y to a full 64-bits.  temp was already
140      ;; sign-extended by the sra instruction above.
141      (inst sra y 0)
142      (inst mulx hi temp y)
143      (inst move lo hi)
144      (inst srax hi 32))
145     ((or (member :sparc-v8 *backend-subfeatures*)
146          (member :sparc-v9 *backend-subfeatures*))
147      (inst smul lo temp y)
148      (inst rdy hi))
149     (t
150      (let ((MULTIPLIER-POSITIVE (gen-label)))
151        (inst wry temp)
152        (inst andcc hi zero-tn)
153        (inst nop)
154        (inst nop)
155        (dotimes (i 32)
156          (inst mulscc hi y))
157        (inst mulscc hi zero-tn)
158        (inst cmp x)
159        (inst b :ge MULTIPLIER-POSITIVE)
160        (inst nop)
161        (inst sub hi y)
162        (emit-label MULTIPLIER-POSITIVE)
163        (inst rdy lo))))
164   ;; Check to see if the result will fit in a fixnum.  (I.e. the high word
165   ;; is just 32 copies of the sign bit of the low word).
166   (inst sra temp lo 31)
167   (inst xorcc temp hi)
168   (inst b :eq LOW-FITS-IN-FIXNUM)
169   ;; Shift the double word hi:lo down two bits to get rid of the fixnum tag.
170   (inst sll temp hi 30)
171   (inst srl lo n-fixnum-tag-bits)
172   (inst or lo temp)
173   (inst sra hi n-fixnum-tag-bits)
174   ;; Allocate a BIGNUM for the result.
175   #+nil
176   (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset)))
177                  (let ((one-word (gen-label)))
178                    (inst or res alloc-tn other-pointer-lowtag)
179                    ;; We start out assuming that we need one word.  Is that correct?
180                    (inst sra temp lo 31)
181                    (inst xorcc temp hi)
182                    (inst b :eq one-word)
183                    (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
184                    ;; Nope, we need two, so allocate the addition space.
185                    (inst add alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset))
186                                          (pad-data-block (1+ bignum-digits-offset))))
187                    (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
188                    (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
189                    (emit-label one-word)
190                    (storew temp res 0 other-pointer-lowtag)
191                    (storew lo res bignum-digits-offset other-pointer-lowtag)))
192   ;; Always allocate 2 words for the bignum result, even if we only
193   ;; need one.  The copying GC will take care of the extra word if it
194   ;; isn't needed.
195   (with-fixed-allocation
196       (res temp bignum-widetag (+ 2 bignum-digits-offset))
197     (let ((one-word (gen-label)))
198       (inst or res alloc-tn other-pointer-lowtag)
199       ;; We start out assuming that we need one word.  Is that correct?
200       (inst sra temp lo 31)
201       (inst xorcc temp hi)
202       (inst b :eq one-word)
203       (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
204       ;; Need 2 words.  Set the header appropriately, and save the
205       ;; high and low parts.
206       (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
207       (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
208       (emit-label one-word)
209       (storew temp res 0 other-pointer-lowtag)
210       (storew lo res bignum-digits-offset other-pointer-lowtag)))
211   ;; Out of here
212   (lisp-return lra :offset 2)
213   
214   DO-STATIC-FUN
215   (inst ld code-tn null-tn (static-fun-offset 'two-arg-*))
216   (inst li nargs (fixnumize 2))
217   (inst move ocfp cfp-tn)
218   (inst j code-tn
219         (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
220   (inst move cfp-tn csp-tn)
221
222   LOW-FITS-IN-FIXNUM
223   (move res lo))
224
225 (macrolet
226     ((frob (name note cost type sc)
227        `(define-assembly-routine (,name
228                                   (:note ,note)
229                                   (:cost ,cost)
230                                   (:translate *)
231                                   (:policy :fast-safe)
232                                   (:arg-types ,type ,type)
233                                   (:result-types ,type))
234                                  ((:arg x ,sc nl0-offset)
235                                   (:arg y ,sc nl1-offset)
236                                   (:res res ,sc nl0-offset)
237                                   (:temp temp ,sc nl2-offset))
238           ,@(when (eq type 'tagged-num)
239               `((inst sra x 2)))
240          (cond
241            ((member :sparc-64 *backend-subfeatures*)
242             ;; Sign extend, then multiply
243             (inst sra x 0)
244             (inst sra y 0)
245             (inst mulx res x y))
246            ((or (member :sparc-v8 *backend-subfeatures*)
247                 (member :sparc-v9 *backend-subfeatures*))
248             (inst smul res x y))
249            (t
250             (inst wry x)
251             (inst andcc temp zero-tn)
252             (inst nop)
253             (inst nop)
254             (dotimes (i 32)
255               (inst mulscc temp y))
256             (inst mulscc temp zero-tn)
257            (inst rdy res))))))
258   (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg)
259   (frob signed-* "unsigned *" 41 signed-num signed-reg)
260   (frob fixnum-* "fixnum *" 30 tagged-num any-reg))
261
262
263 \f
264 ;;;; Division.
265
266 #+sb-assembling
267 (defun emit-divide-loop (divisor rem quo tagged)
268   (inst li quo 0)
269   (labels
270       ((do-loop (depth)
271          (cond
272           ((zerop depth)
273            (inst unimp 0))
274           (t
275            (let ((label-1 (gen-label))
276                  (label-2 (gen-label)))
277              (inst cmp divisor rem)
278              (inst b :geu label-1)
279              (inst nop)
280              (inst sll divisor 1)
281              (do-loop (1- depth))
282              (inst srl divisor 1)
283              (inst cmp divisor rem)
284              (emit-label label-1)
285              (inst b :gtu label-2)
286              (inst sll quo 1)
287              (inst add quo (if tagged (fixnumize 1) 1))
288              (inst sub rem divisor)
289              (emit-label label-2))))))
290     (do-loop (if tagged 30 32))))
291
292 (define-assembly-routine (positive-fixnum-truncate
293                           (:note "unsigned fixnum truncate")
294                           (:cost 45)
295                           (:translate truncate)
296                           (:policy :fast-safe)
297                           (:arg-types positive-fixnum positive-fixnum)
298                           (:result-types positive-fixnum positive-fixnum))
299                          ((:arg dividend any-reg nl0-offset)
300                           (:arg divisor any-reg nl1-offset)
301
302                           (:res quo any-reg nl2-offset)
303                           (:res rem any-reg nl0-offset))
304
305   (let ((error (generate-error-code nil division-by-zero-error
306                                     dividend divisor)))
307     (inst cmp divisor)
308     (inst b :eq error))
309
310   (move rem dividend)
311   (emit-divide-loop divisor rem quo t))
312
313
314 (define-assembly-routine (fixnum-truncate
315                           (:note "fixnum truncate")
316                           (:cost 50)
317                           (:policy :fast-safe)
318                           (:translate truncate)
319                           (:arg-types tagged-num tagged-num)
320                           (:result-types tagged-num tagged-num))
321                          ((:arg dividend any-reg nl0-offset)
322                           (:arg divisor any-reg nl1-offset)
323
324                           (:res quo any-reg nl2-offset)
325                           (:res rem any-reg nl0-offset)
326
327                           (:temp quo-sign any-reg nl5-offset)
328                           (:temp rem-sign any-reg nargs-offset))
329   
330   (let ((error (generate-error-code nil division-by-zero-error
331                                     dividend divisor)))
332     (inst cmp divisor)
333     (inst b :eq error))
334
335   (inst xor quo-sign dividend divisor)
336   (inst move rem-sign dividend)
337   (let ((label (gen-label)))
338     (inst cmp dividend)
339     (inst ba :lt label)
340     (inst neg dividend)
341     (emit-label label))
342   (let ((label (gen-label)))
343     (inst cmp divisor)
344     (inst ba :lt label)
345     (inst neg divisor)
346     (emit-label label))
347   (move rem dividend)
348   (emit-divide-loop divisor rem quo t)
349   (let ((label (gen-label)))
350     ;; If the quo-sign is negative, we need to negate quo.
351     (inst cmp quo-sign)
352     (inst ba :lt label)
353     (inst neg quo)
354     (emit-label label))
355   (let ((label (gen-label)))
356     ;; If the rem-sign is negative, we need to negate rem.
357     (inst cmp rem-sign)
358     (inst ba :lt label)
359     (inst neg rem)
360     (emit-label label)))
361
362
363 (define-assembly-routine (signed-truncate
364                           (:note "(signed-byte 32) truncate")
365                           (:cost 60)
366                           (:policy :fast-safe)
367                           (:translate truncate)
368                           (:arg-types signed-num signed-num)
369                           (:result-types signed-num signed-num))
370
371                          ((:arg dividend signed-reg nl0-offset)
372                           (:arg divisor signed-reg nl1-offset)
373
374                           (:res quo signed-reg nl2-offset)
375                           (:res rem signed-reg nl0-offset)
376
377                           (:temp quo-sign signed-reg nl5-offset)
378                           (:temp rem-sign signed-reg nargs-offset))
379   
380   (let ((error (generate-error-code nil division-by-zero-error
381                                     dividend divisor)))
382     (inst cmp divisor)
383     (inst b :eq error))
384
385   (inst xor quo-sign dividend divisor)
386   (inst move rem-sign dividend)
387   (let ((label (gen-label)))
388     (inst cmp dividend)
389     (inst ba :lt label)
390     (inst neg dividend)
391     (emit-label label))
392   (let ((label (gen-label)))
393     (inst cmp divisor)
394     (inst ba :lt label)
395     (inst neg divisor)
396     (emit-label label))
397   (move rem dividend)
398   (emit-divide-loop divisor rem quo nil)
399   (let ((label (gen-label)))
400     ;; If the quo-sign is negative, we need to negate quo.
401     (inst cmp quo-sign)
402     (inst ba :lt label)
403     (inst neg quo)
404     (emit-label label))
405   (let ((label (gen-label)))
406     ;; If the rem-sign is negative, we need to negate rem.
407     (inst cmp rem-sign)
408     (inst ba :lt label)
409     (inst neg rem)
410     (emit-label label)))
411
412 \f
413 ;;;; Comparison
414
415 (macrolet
416     ((define-cond-assem-rtn (name translate static-fn cmp)
417        `(define-assembly-routine (,name
418                                   (:cost 10)
419                                   (:return-style :full-call)
420                                   (:policy :safe)
421                                   (:translate ,translate)
422                                   (:save-p t))
423                                  ((:arg x (descriptor-reg any-reg) a0-offset)
424                                   (:arg y (descriptor-reg any-reg) a1-offset)
425                                   
426                                   (:res res descriptor-reg a0-offset)
427                                   
428                                   (:temp nargs any-reg nargs-offset)
429                                   (:temp ocfp any-reg ocfp-offset))
430           (inst andcc zero-tn x fixnum-tag-mask)
431           (inst b :ne DO-STATIC-FN)
432           (inst andcc zero-tn y fixnum-tag-mask)
433           (inst b :eq DO-COMPARE)
434           (inst cmp x y)
435           
436           DO-STATIC-FN
437           (inst ld code-tn null-tn (static-fun-offset ',static-fn))
438           (inst li nargs (fixnumize 2))
439           (inst move ocfp cfp-tn)
440           (inst j code-tn
441                 (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
442           (inst move cfp-tn csp-tn)
443           
444           DO-COMPARE
445           (inst b ,cmp done)
446           (load-symbol res t)
447           (inst move res null-tn)
448           DONE)))
449
450   (define-cond-assem-rtn generic-< < two-arg-< :lt)
451   (define-cond-assem-rtn generic-<= <= two-arg-<= :le)
452   (define-cond-assem-rtn generic-> > two-arg-> :gt)
453   (define-cond-assem-rtn generic->= >= two-arg->= :ge))
454
455
456 (define-assembly-routine (generic-eql
457                           (:cost 10)
458                           (:return-style :full-call)
459                           (:policy :safe)
460                           (:translate eql)
461                           (:save-p t))
462                          ((:arg x (descriptor-reg any-reg) a0-offset)
463                           (:arg y (descriptor-reg any-reg) a1-offset)
464                           
465                           (:res res descriptor-reg a0-offset)
466
467                           (:temp lra descriptor-reg lra-offset)
468                           (:temp nargs any-reg nargs-offset)
469                           (:temp ocfp any-reg ocfp-offset))
470   (inst cmp x y)
471   (inst b :eq RETURN-T)
472   (inst andcc zero-tn x fixnum-tag-mask)
473   (inst b :eq RETURN-NIL)
474   (inst andcc zero-tn y fixnum-tag-mask)
475   (inst b :ne DO-STATIC-FN)
476   (inst nop)
477
478   RETURN-NIL
479   (inst move res null-tn)
480   (lisp-return lra :offset 2)
481
482   DO-STATIC-FN
483   (inst ld code-tn null-tn (static-fun-offset 'eql))
484   (inst li nargs (fixnumize 2))
485   (inst move ocfp cfp-tn)
486   (inst j code-tn
487         (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
488   (inst move cfp-tn csp-tn)
489
490   RETURN-T
491   (load-symbol res t))
492
493 (define-assembly-routine (generic-=
494                           (:cost 10)
495                           (:return-style :full-call)
496                           (:policy :safe)
497                           (:translate =)
498                           (:save-p t))
499                          ((:arg x (descriptor-reg any-reg) a0-offset)
500                           (:arg y (descriptor-reg any-reg) a1-offset)
501
502                           (:res res descriptor-reg a0-offset)
503
504                           (:temp lra descriptor-reg lra-offset)
505                           (:temp nargs any-reg nargs-offset)
506                           (:temp ocfp any-reg ocfp-offset))
507   (inst andcc zero-tn x fixnum-tag-mask)
508   (inst b :ne DO-STATIC-FN)
509   (inst andcc zero-tn y fixnum-tag-mask)
510   (inst b :ne DO-STATIC-FN)
511   (inst cmp x y)
512   (inst b :eq RETURN-T)
513   (inst nop)
514
515   (inst move res null-tn)
516   (lisp-return lra :offset 2)
517
518   DO-STATIC-FN
519   (inst ld code-tn null-tn (static-fun-offset 'two-arg-=))
520   (inst li nargs (fixnumize 2))
521   (inst move ocfp cfp-tn)
522   (inst j code-tn
523         (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
524   (inst move cfp-tn csp-tn)
525
526   RETURN-T
527   (load-symbol res t))
528
529 (define-assembly-routine (generic-/=
530                           (:cost 10)
531                           (:return-style :full-call)
532                           (:policy :safe)
533                           (:translate /=)
534                           (:save-p t))
535                          ((:arg x (descriptor-reg any-reg) a0-offset)
536                           (:arg y (descriptor-reg any-reg) a1-offset)
537
538                           (:res res descriptor-reg a0-offset)
539
540                           (:temp lra descriptor-reg lra-offset)
541                           (:temp nargs any-reg nargs-offset)
542                           (:temp ocfp any-reg ocfp-offset))
543   (inst cmp x y)
544   (inst b :eq RETURN-NIL)
545   (inst andcc zero-tn x fixnum-tag-mask)
546   (inst b :ne DO-STATIC-FN)
547   (inst andcc zero-tn y fixnum-tag-mask)
548   (inst b :ne DO-STATIC-FN)
549   (inst nop)
550
551   (load-symbol res t)
552   (lisp-return lra :offset 2)
553
554   DO-STATIC-FN
555   (inst ld code-tn null-tn (static-fun-offset 'two-arg-=))
556   (inst li nargs (fixnumize 2))
557   (inst move ocfp cfp-tn)
558   (inst j code-tn
559         (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
560   (inst move cfp-tn csp-tn)
561
562   RETURN-NIL
563   (inst move res null-tn))