Truthful error reporting for complicated compile-time type mismatches
[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   ;; Always allocate 2 words for the bignum result, even if we only
175   ;; need one.  The copying GC will take care of the extra word if it
176   ;; isn't needed.
177   (with-fixed-allocation
178       (res temp bignum-widetag (+ 2 bignum-digits-offset))
179     (let ((one-word (gen-label)))
180       ;; We start out assuming that we need one word.  Is that correct?
181       (inst sra temp lo 31)
182       (inst xorcc temp hi)
183       (inst b :eq one-word)
184       (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
185       ;; Need 2 words.  Set the header appropriately, and save the
186       ;; high and low parts.
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   ;; Out of here
193   (lisp-return lra :offset 2)
194
195   DO-STATIC-FUN
196   (inst ld code-tn null-tn (static-fun-offset 'two-arg-*))
197   (inst li nargs (fixnumize 2))
198   (inst move ocfp cfp-tn)
199   (inst j code-tn
200         (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
201   (inst move cfp-tn csp-tn)
202
203   LOW-FITS-IN-FIXNUM
204   (move res lo))
205
206 (macrolet
207     ((frob (name note cost type sc)
208        `(define-assembly-routine (,name
209                                   (:note ,note)
210                                   (:cost ,cost)
211                                   (:translate *)
212                                   (:policy :fast-safe)
213                                   (:arg-types ,type ,type)
214                                   (:result-types ,type))
215                                  ((:arg x ,sc nl0-offset)
216                                   (:arg y ,sc nl1-offset)
217                                   (:res res ,sc nl0-offset)
218                                   (:temp temp ,sc nl2-offset))
219           ,@(when (eq type 'tagged-num)
220               `((inst sra x 2)))
221          (cond
222            ((member :sparc-64 *backend-subfeatures*)
223             ;; Sign extend, then multiply
224             (inst sra x 0)
225             (inst sra y 0)
226             (inst mulx res x y))
227            ((or (member :sparc-v8 *backend-subfeatures*)
228                 (member :sparc-v9 *backend-subfeatures*))
229             (inst smul res x y))
230            (t
231             (inst wry x)
232             (inst andcc temp zero-tn)
233             (inst nop)
234             (inst nop)
235             (dotimes (i 32)
236               (inst mulscc temp y))
237             (inst mulscc temp zero-tn)
238            (inst rdy res))))))
239   (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg)
240   (frob signed-* "signed *" 41 signed-num signed-reg)
241   (frob fixnum-* "fixnum *" 30 tagged-num any-reg))
242
243
244 \f
245 ;;;; Division.
246
247 #+sb-assembling
248 (defun emit-divide-loop (divisor rem quo tagged)
249   (inst li quo 0)
250   (labels
251       ((do-loop (depth)
252          (cond
253           ((zerop depth)
254            (inst unimp 0))
255           (t
256            (let ((label-1 (gen-label))
257                  (label-2 (gen-label)))
258              (inst cmp divisor rem)
259              (inst b :geu label-1)
260              (inst nop)
261              (inst sll divisor 1)
262              (do-loop (1- depth))
263              (inst srl divisor 1)
264              (inst cmp divisor rem)
265              (emit-label label-1)
266              (inst b :gtu label-2)
267              (inst sll quo 1)
268              (inst add quo (if tagged (fixnumize 1) 1))
269              (inst sub rem divisor)
270              (emit-label label-2))))))
271     (do-loop (if tagged 30 32))))
272
273 (define-assembly-routine (positive-fixnum-truncate
274                           (:note "unsigned fixnum truncate")
275                           (:cost 45)
276                           (:translate truncate)
277                           (:policy :fast-safe)
278                           (:arg-types positive-fixnum positive-fixnum)
279                           (:result-types positive-fixnum positive-fixnum))
280                          ((:arg dividend any-reg nl0-offset)
281                           (:arg divisor any-reg nl1-offset)
282
283                           (:res quo any-reg nl2-offset)
284                           (:res rem any-reg nl0-offset))
285
286   (let ((error (generate-error-code nil division-by-zero-error
287                                     dividend divisor)))
288     (inst cmp divisor)
289     (inst b :eq error))
290
291   (move rem dividend)
292   (emit-divide-loop divisor rem quo t))
293
294
295 (define-assembly-routine (fixnum-truncate
296                           (:note "fixnum truncate")
297                           (:cost 50)
298                           (:policy :fast-safe)
299                           (:translate truncate)
300                           (:arg-types tagged-num tagged-num)
301                           (:result-types tagged-num tagged-num))
302                          ((:arg dividend any-reg nl0-offset)
303                           (:arg divisor any-reg nl1-offset)
304
305                           (:res quo any-reg nl2-offset)
306                           (:res rem any-reg nl0-offset)
307
308                           (:temp quo-sign any-reg nl5-offset)
309                           (:temp rem-sign any-reg nargs-offset))
310
311   (let ((error (generate-error-code nil division-by-zero-error
312                                     dividend divisor)))
313     (inst cmp divisor)
314     (inst b :eq error))
315
316   (inst xor quo-sign dividend divisor)
317   (inst move rem-sign dividend)
318   (let ((label (gen-label)))
319     (inst cmp dividend)
320     (inst ba :lt label)
321     (inst neg dividend)
322     (emit-label label))
323   (let ((label (gen-label)))
324     (inst cmp divisor)
325     (inst ba :lt label)
326     (inst neg divisor)
327     (emit-label label))
328   (move rem dividend)
329   (emit-divide-loop divisor rem quo t)
330   (let ((label (gen-label)))
331     ;; If the quo-sign is negative, we need to negate quo.
332     (inst cmp quo-sign)
333     (inst ba :lt label)
334     (inst neg quo)
335     (emit-label label))
336   (let ((label (gen-label)))
337     ;; If the rem-sign is negative, we need to negate rem.
338     (inst cmp rem-sign)
339     (inst ba :lt label)
340     (inst neg rem)
341     (emit-label label)))
342
343
344 (define-assembly-routine (signed-truncate
345                           (:note "(signed-byte 32) truncate")
346                           (:cost 60)
347                           (:policy :fast-safe)
348                           (:translate truncate)
349                           (:arg-types signed-num signed-num)
350                           (:result-types signed-num signed-num))
351
352                          ((:arg dividend signed-reg nl0-offset)
353                           (:arg divisor signed-reg nl1-offset)
354
355                           (:res quo signed-reg nl2-offset)
356                           (:res rem signed-reg nl0-offset)
357
358                           (:temp quo-sign signed-reg nl5-offset)
359                           (:temp rem-sign signed-reg nargs-offset))
360
361   (let ((error (generate-error-code nil division-by-zero-error
362                                     dividend divisor)))
363     (inst cmp divisor)
364     (inst b :eq error))
365
366   (inst xor quo-sign dividend divisor)
367   (inst move rem-sign dividend)
368   (let ((label (gen-label)))
369     (inst cmp dividend)
370     (inst ba :lt label)
371     (inst neg dividend)
372     (emit-label label))
373   (let ((label (gen-label)))
374     (inst cmp divisor)
375     (inst ba :lt label)
376     (inst neg divisor)
377     (emit-label label))
378   (move rem dividend)
379   (emit-divide-loop divisor rem quo nil)
380   (let ((label (gen-label)))
381     ;; If the quo-sign is negative, we need to negate quo.
382     (inst cmp quo-sign)
383     (inst ba :lt label)
384     (inst neg quo)
385     (emit-label label))
386   (let ((label (gen-label)))
387     ;; If the rem-sign is negative, we need to negate rem.
388     (inst cmp rem-sign)
389     (inst ba :lt label)
390     (inst neg rem)
391     (emit-label label)))
392
393 \f
394 ;;;; Comparison
395
396 (macrolet
397     ((define-cond-assem-rtn (name translate static-fn cmp)
398        `(define-assembly-routine (,name
399                                   (:cost 10)
400                                   (:return-style :full-call)
401                                   (:policy :safe)
402                                   (:translate ,translate)
403                                   (:save-p t))
404                                  ((:arg x (descriptor-reg any-reg) a0-offset)
405                                   (:arg y (descriptor-reg any-reg) a1-offset)
406
407                                   (:res res descriptor-reg a0-offset)
408
409                                   (:temp nargs any-reg nargs-offset)
410                                   (:temp ocfp any-reg ocfp-offset))
411           (inst andcc zero-tn x fixnum-tag-mask)
412           (inst b :ne DO-STATIC-FN)
413           (inst andcc zero-tn y fixnum-tag-mask)
414           (inst b :eq DO-COMPARE)
415           (inst cmp x y)
416
417           DO-STATIC-FN
418           (inst ld code-tn null-tn (static-fun-offset ',static-fn))
419           (inst li nargs (fixnumize 2))
420           (inst move ocfp cfp-tn)
421           (inst j code-tn
422                 (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
423           (inst move cfp-tn csp-tn)
424
425           DO-COMPARE
426           (inst b ,cmp done)
427           (load-symbol res t)
428           (inst move res null-tn)
429           DONE)))
430
431   (define-cond-assem-rtn generic-< < two-arg-< :lt)
432   (define-cond-assem-rtn generic-<= <= two-arg-<= :le)
433   (define-cond-assem-rtn generic-> > two-arg-> :gt)
434   (define-cond-assem-rtn generic->= >= two-arg->= :ge))
435
436
437 (define-assembly-routine (generic-eql
438                           (:cost 10)
439                           (:return-style :full-call)
440                           (:policy :safe)
441                           (:translate eql)
442                           (:save-p t))
443                          ((:arg x (descriptor-reg any-reg) a0-offset)
444                           (:arg y (descriptor-reg any-reg) a1-offset)
445
446                           (:res res descriptor-reg a0-offset)
447
448                           (:temp lra descriptor-reg lra-offset)
449                           (:temp nargs any-reg nargs-offset)
450                           (:temp ocfp any-reg ocfp-offset))
451   (inst cmp x y)
452   (inst b :eq RETURN-T)
453   (inst andcc zero-tn x fixnum-tag-mask)
454   (inst b :eq RETURN-NIL)
455   (inst andcc zero-tn y fixnum-tag-mask)
456   (inst b :ne DO-STATIC-FN)
457   (inst nop)
458
459   RETURN-NIL
460   (inst move res null-tn)
461   (lisp-return lra :offset 2)
462
463   DO-STATIC-FN
464   (inst ld code-tn null-tn (static-fun-offset 'eql))
465   (inst li nargs (fixnumize 2))
466   (inst move ocfp cfp-tn)
467   (inst j code-tn
468         (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
469   (inst move cfp-tn csp-tn)
470
471   RETURN-T
472   (load-symbol res t))
473
474 (define-assembly-routine (generic-=
475                           (:cost 10)
476                           (:return-style :full-call)
477                           (:policy :safe)
478                           (:translate =)
479                           (:save-p t))
480                          ((:arg x (descriptor-reg any-reg) a0-offset)
481                           (:arg y (descriptor-reg any-reg) a1-offset)
482
483                           (:res res descriptor-reg a0-offset)
484
485                           (:temp lra descriptor-reg lra-offset)
486                           (:temp nargs any-reg nargs-offset)
487                           (:temp ocfp any-reg ocfp-offset))
488   (inst andcc zero-tn x fixnum-tag-mask)
489   (inst b :ne DO-STATIC-FN)
490   (inst andcc zero-tn y fixnum-tag-mask)
491   (inst b :ne DO-STATIC-FN)
492   (inst cmp x y)
493   (inst b :eq RETURN-T)
494   (inst nop)
495
496   (inst move res null-tn)
497   (lisp-return lra :offset 2)
498
499   DO-STATIC-FN
500   (inst ld code-tn null-tn (static-fun-offset 'two-arg-=))
501   (inst li nargs (fixnumize 2))
502   (inst move ocfp cfp-tn)
503   (inst j code-tn
504         (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
505   (inst move cfp-tn csp-tn)
506
507   RETURN-T
508   (load-symbol res t))
509
510 (define-assembly-routine (generic-/=
511                           (:cost 10)
512                           (:return-style :full-call)
513                           (:policy :safe)
514                           (:translate /=)
515                           (:save-p t))
516                          ((:arg x (descriptor-reg any-reg) a0-offset)
517                           (:arg y (descriptor-reg any-reg) a1-offset)
518
519                           (:res res descriptor-reg a0-offset)
520
521                           (:temp lra descriptor-reg lra-offset)
522                           (:temp nargs any-reg nargs-offset)
523                           (:temp ocfp any-reg ocfp-offset))
524   (inst cmp x y)
525   (inst b :eq RETURN-NIL)
526   (inst andcc zero-tn x fixnum-tag-mask)
527   (inst b :ne DO-STATIC-FN)
528   (inst andcc zero-tn y fixnum-tag-mask)
529   (inst b :ne DO-STATIC-FN)
530   (inst nop)
531
532   (load-symbol res t)
533   (lisp-return lra :offset 2)
534
535   DO-STATIC-FN
536   (inst ld code-tn null-tn (static-fun-offset 'two-arg-/=))
537   (inst li nargs (fixnumize 2))
538   (inst move ocfp cfp-tn)
539   (inst j code-tn
540         (- (* simple-fun-code-offset n-word-bytes) fun-pointer-lowtag))
541   (inst move cfp-tn csp-tn)
542
543   RETURN-NIL
544   (inst move res null-tn))