1;;;; the VM definition arithmetic VOPs for the SPARC
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
14;;;; unary operations.
15
16(define-vop (fast-safe-arith-op)
17  (:policy :fast-safe)
18  (:effects)
19  (:affected))
20
21(define-vop (fixnum-unop fast-safe-arith-op)
22  (:args (x :scs (any-reg)))
23  (:results (res :scs (any-reg)))
24  (:note "inline fixnum arithmetic")
25  (:arg-types tagged-num)
26  (:result-types tagged-num))
27
28(define-vop (signed-unop fast-safe-arith-op)
29  (:args (x :scs (signed-reg)))
30  (:results (res :scs (signed-reg)))
31  (:note "inline (signed-byte 32) arithmetic")
32  (:arg-types signed-num)
33  (:result-types signed-num))
34
35(define-vop (fast-negate/fixnum fixnum-unop)
36  (:translate %negate)
37  (:generator 1
38    (inst neg res x)))
39
40(define-vop (fast-negate/signed signed-unop)
41  (:translate %negate)
42  (:generator 2
43    (inst neg res x)))
44
45(define-vop (fast-lognot/fixnum fixnum-unop)
46  (:translate lognot)
47  (:generator 1
48    (inst xor res x (fixnumize -1))))
49
50(define-vop (fast-lognot/signed signed-unop)
51  (:translate lognot)
52  (:generator 2
53    (inst not res x)))
54
55;;;; Binary fixnum operations.
56
57;;; Assume that any constant operand is the second arg...
58
59(define-vop (fast-fixnum-binop fast-safe-arith-op)
60  (:args (x :target r :scs (any-reg zero))
61         (y :target r :scs (any-reg zero)))
62  (:arg-types tagged-num tagged-num)
63  (:results (r :scs (any-reg)))
64  (:result-types tagged-num)
65  (:note "inline fixnum arithmetic"))
66
67(define-vop (fast-unsigned-binop fast-safe-arith-op)
68  (:args (x :target r :scs (unsigned-reg zero))
69         (y :target r :scs (unsigned-reg zero)))
70  (:arg-types unsigned-num unsigned-num)
71  (:results (r :scs (unsigned-reg)))
72  (:result-types unsigned-num)
73  (:note "inline (unsigned-byte 32) arithmetic"))
74
75(define-vop (fast-signed-binop fast-safe-arith-op)
76  (:args (x :target r :scs (signed-reg zero))
77         (y :target r :scs (signed-reg zero)))
78  (:arg-types signed-num signed-num)
79  (:results (r :scs (signed-reg)))
80  (:result-types signed-num)
81  (:note "inline (signed-byte 32) arithmetic"))
82
83
84(define-vop (fast-fixnum-binop-c fast-safe-arith-op)
85  (:args (x :target r :scs (any-reg zero)))
86  (:info y)
87  (:arg-types tagged-num
88              (:constant (and (signed-byte 11) (not (integer 0 0)))))
89  (:results (r :scs (any-reg)))
90  (:result-types tagged-num)
91  (:note "inline fixnum arithmetic"))
92
93(define-vop (fast-unsigned-binop-c fast-safe-arith-op)
94  (:args (x :target r :scs (unsigned-reg zero)))
95  (:info y)
96  (:arg-types unsigned-num
97              (:constant (and (signed-byte 13) (not (integer 0 0)))))
98  (:results (r :scs (unsigned-reg)))
99  (:result-types unsigned-num)
100  (:note "inline (unsigned-byte 32) arithmetic"))
101
102(define-vop (fast-signed-binop-c fast-safe-arith-op)
103  (:args (x :target r :scs (signed-reg zero)))
104  (:info y)
105  (:arg-types signed-num
106              (:constant (and (signed-byte 13) (not (integer 0 0)))))
107  (:results (r :scs (signed-reg)))
108  (:result-types signed-num)
109  (:note "inline (signed-byte 32) arithmetic"))
110
111
112(eval-when (:compile-toplevel :load-toplevel :execute)
113
114(defmacro define-binop (translate untagged-penalty op
115                        &optional arg-swap restore-fixnum-mask)
116  `(progn
117     (define-vop (,(symbolicate 'fast translate '/fixnum=>fixnum)
118                  fast-fixnum-binop)
119       ,@(when restore-fixnum-mask
120           `((:temporary (:sc non-descriptor-reg) temp)))
121       (:translate ,translate)
122       (:generator 2
123         ,(if arg-swap
124              `(inst ,op ,(if restore-fixnum-mask 'temp 'r) y x)
125              `(inst ,op ,(if restore-fixnum-mask 'temp 'r) x y))
126         ,@(when restore-fixnum-mask
127             `((inst andn r temp fixnum-tag-mask)))))
128     ,@(unless arg-swap
129         `((define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
130                        fast-fixnum-binop-c)
131             ,@(when restore-fixnum-mask
132                 `((:temporary (:sc non-descriptor-reg) temp)))
133             (:translate ,translate)
134             (:generator 1
135               (inst ,op ,(if restore-fixnum-mask 'temp 'r) x (fixnumize y))
136               ,@(when restore-fixnum-mask
137                   `((inst andn r temp fixnum-tag-mask)))))))
138     (define-vop (,(symbolicate 'fast- translate '/signed=>signed)
139                  fast-signed-binop)
140       (:translate ,translate)
141       (:generator ,(1+ untagged-penalty)
142         ,(if arg-swap
143              `(inst ,op r y x)
144              `(inst ,op r x y))))
145     ,@(unless arg-swap
146         `((define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
147                        fast-signed-binop-c)
148             (:translate ,translate)
149             (:generator ,untagged-penalty
150               (inst ,op r x y)))))
151     (define-vop (,(symbolicate 'fast- translate '/unsigned=>unsigned)
152                  fast-unsigned-binop)
153       (:translate ,translate)
154       (:generator ,(1+ untagged-penalty)
155         ,(if arg-swap
156              `(inst ,op r y x)
157              `(inst ,op r x y))))
158     ,@(unless arg-swap
159         `((define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
160                        fast-unsigned-binop-c)
161             (:translate ,translate)
162             (:generator ,untagged-penalty
163               (inst ,op r x y)))))))
164
165); eval-when
166
167(define-binop + 4 add)
168(define-binop - 4 sub)
169(define-binop logand 2 and)
170(define-binop logandc1 2 andn t)
171(define-binop logandc2 2 andn)
172(define-binop logior 2 or)
173(define-binop logorc1 2 orn t t)
174(define-binop logorc2 2 orn nil t)
175(define-binop logxor 2 xor)
176(define-binop logeqv 2 xnor nil t)
177
178(define-vop (fast-logand/signed-unsigned=>unsigned fast-logand/unsigned=>unsigned)
179  (:args (x :scs (signed-reg) :target r)
180         (y :scs (unsigned-reg) :target r))
181  (:arg-types signed-num unsigned-num)
182  (:translate logand))
183
184;;; Truncate
185
186;; This doesn't work for some reason.
187#+nil
188(define-vop (fast-v8-truncate/fixnum=>fixnum fast-safe-arith-op)
189  (:translate truncate)
190  (:args (x :scs (any-reg))
191         (y :scs (any-reg)))
192  (:arg-types tagged-num tagged-num)
193  (:results (quo :scs (any-reg))
194            (rem :scs (any-reg)))
195  (:result-types tagged-num tagged-num)
196  (:note "inline fixnum arithmetic")
197  (:temporary (:scs (any-reg) :target quo) q)
198  (:temporary (:scs (any-reg)) r)
199  (:temporary (:scs (signed-reg)) y-int)
200  (:vop-var vop)
201  (:save-p :compute-only)
202  (:guard (or (member :sparc-v8 *backend-subfeatures*)
203              (and (member :sparc-v9 *backend-subfeatures*)
204                   (not (member :sparc-64 *backend-subfeatures*)))))
205  (:generator 12
206    (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
207      (inst cmp y zero-tn)
208      (inst b :eq zero)
209      ;; Extend the sign of X into the Y register
210        (inst sra r x 31)
211      (inst wry r)
212      ;; Remove tag bits so Q and R will be tagged correctly.
213      (inst sra y-int y n-fixnum-tag-bits)
214      (inst nop)
215      (inst nop)
216
217      (inst sdiv q x y-int)             ; Q is tagged.
218      ;; We have the quotient so we need to compute the remainder
219      (inst smul r q y-int)             ; R is tagged
220      (inst sub rem x r)
221      (unless (location= quo q)
222        (move quo q)))))
223
224(define-vop (fast-v8-truncate/signed=>signed fast-safe-arith-op)
225  (:translate truncate)
226  (:args (x :scs (signed-reg))
227         (y :scs (signed-reg)))
228  (:arg-types signed-num signed-num)
229  (:results (quo :scs (signed-reg))
230            (rem :scs (signed-reg)))
231  (:result-types signed-num signed-num)
232  (:note "inline (signed-byte 32) arithmetic")
233  (:temporary (:scs (signed-reg) :target quo) q)
234  (:temporary (:scs (signed-reg)) r)
235  (:vop-var vop)
236  (:save-p :compute-only)
237  (:guard (or (member :sparc-v8 *backend-subfeatures*)
238              (and (member :sparc-v9 *backend-subfeatures*)
239                   (not (member :sparc-64 *backend-subfeatures*)))))
240  (:generator 12
241    (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
242      (inst cmp y zero-tn)
243      (if (member :sparc-v9 *backend-subfeatures*)
244          (inst b :eq zero :pn)
245          (inst b :eq zero))
246      ;; Extend the sign of X into the Y register
247      (inst sra r x 31)
248      (inst wry r)
249      (inst nop)
250      (inst nop)
251      (inst nop)
252
253      (inst sdiv q x y)
254      ;; We have the quotient so we need to compue the remainder
255      (inst smul r q y)         ; rem
256      (inst sub rem x r)
257      (unless (location= quo q)
258        (move quo q)))))
259
260(define-vop (fast-v8-truncate/unsigned=>unsigned fast-safe-arith-op)
261  (:translate truncate)
262  (:args (x :scs (unsigned-reg))
263         (y :scs (unsigned-reg)))
264  (:arg-types unsigned-num unsigned-num)
265  (:results (quo :scs (unsigned-reg))
266            (rem :scs (unsigned-reg)))
267  (:result-types unsigned-num unsigned-num)
268  (:note "inline (unsigned-byte 32) arithmetic")
269  (:temporary (:scs (unsigned-reg) :target quo) q)
270  (:temporary (:scs (unsigned-reg)) r)
271  (:vop-var vop)
272  (:save-p :compute-only)
273  (:guard (or (member :sparc-v8 *backend-subfeatures*)
274              (and (member :sparc-v9 *backend-subfeatures*)
275                   (not (member :sparc-64 *backend-subfeatures*)))))
276  (:generator 8
277    (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
278      (inst cmp y zero-tn)
279      (if (member :sparc-v9 *backend-subfeatures*)
280          (inst b :eq zero :pn)
281          (inst b :eq zero))
282      (inst wry zero-tn)                ; Clear out high part
283      (inst nop)
284      (inst nop)
285      (inst nop)
286
287      (inst udiv q x y)
288      ;; Compute remainder
289      (inst umul r q y)
290      (inst sub rem x r)
291      (unless (location= quo q)
292        (inst move quo q)))))
293
294(define-vop (fast-v9-truncate/signed=>signed fast-safe-arith-op)
295  (:translate truncate)
296  (:args (x :scs (signed-reg))
297         (y :scs (signed-reg)))
298  (:arg-types signed-num signed-num)
299  (:results (quo :scs (signed-reg))
300            (rem :scs (signed-reg)))
301  (:result-types signed-num signed-num)
302  (:note "inline (signed-byte 32) arithmetic")
303  (:temporary (:scs (signed-reg) :target quo) q)
304  (:temporary (:scs (signed-reg)) r)
305  (:vop-var vop)
306  (:save-p :compute-only)
307  (:guard (member :sparc-64 *backend-subfeatures*))
308  (:generator 8
309    (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
310      (inst cmp y zero-tn)
311      (inst b :eq zero :pn)
312      ;; Sign extend the numbers, just in case.
313      (inst sra x 0)
314      (inst sra y 0)
315      (inst sdivx q x y)
316      ;; Compute remainder
317      (inst mulx r q y)
318      (inst sub rem x r)
319      (unless (location= quo q)
320        (inst move quo q)))))
321
322(define-vop (fast-v9-truncate/unsigned=>unsigned fast-safe-arith-op)
323  (:translate truncate)
324  (:args (x :scs (unsigned-reg))
325         (y :scs (unsigned-reg)))
326  (:arg-types unsigned-num unsigned-num)
327  (:results (quo :scs (unsigned-reg))
328            (rem :scs (unsigned-reg)))
329  (:result-types unsigned-num unsigned-num)
330  (:note "inline (unsigned-byte 32) arithmetic")
331  (:temporary (:scs (unsigned-reg) :target quo) q)
332  (:temporary (:scs (unsigned-reg)) r)
333  (:vop-var vop)
334  (:save-p :compute-only)
335  (:guard (member :sparc-64 *backend-subfeatures*))
336  (:generator 8
337    (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
338      (inst cmp y zero-tn)
339      (inst b :eq zero :pn)
340      ;; Zap the higher 32 bits, just in case
341      (inst srl x 0)
342      (inst srl y 0)
343      (inst udivx q x y)
344      ;; Compute remainder
345      (inst mulx r q y)
346      (inst sub rem x r)
347      (unless (location= quo q)
348        (inst move quo q)))))
349
350;;; Shifting
351
352(define-vop (fast-ash/signed=>signed)
353  (:note "inline ASH")
354  (:args (number :scs (signed-reg) :to :save)
355         (amount :scs (signed-reg) :to :save))
356  (:arg-types signed-num signed-num)
357  (:results (result :scs (signed-reg)))
358  (:result-types signed-num)
359  (:translate ash)
360  (:policy :fast-safe)
361  (:temporary (:sc non-descriptor-reg) ndesc)
362  (:generator 5
363    (let ((done (gen-label)))
364      (inst cmp amount)
365      (inst b :ge done)
366      ;; The result-type assures us that this shift will not
367      ;; overflow.
368      (inst sll result number amount)
369      (inst neg ndesc amount)
370      (inst cmp ndesc 31)
371      (if (member :sparc-v9 *backend-subfeatures*)
372          (progn
373            (inst cmove :ge ndesc 31)
374            (inst sra result number ndesc))
375          (progn
376            (inst b :le done)
377            (inst sra result number ndesc)
378            (inst sra result number 31)))
379      (emit-label done))))
380
381(define-vop (fast-ash-c/signed=>signed)
382  (:note "inline constant ASH")
383  (:args (number :scs (signed-reg)))
384  (:info count)
385  (:arg-types signed-num (:constant integer))
386  (:results (result :scs (signed-reg)))
387  (:result-types signed-num)
388  (:translate ash)
389  (:policy :fast-safe)
390  (:generator 4
391    (cond
392      ((< count 0) (inst sra result number (min (- count) 31)))
393      ((> count 0) (inst sll result number (min count 31)))
394      (t (bug "identity ASH not transformed away")))))
395
396(define-vop (fast-ash/unsigned=>unsigned)
397  (:note "inline ASH")
398  (:args (number :scs (unsigned-reg) :to :save)
399         (amount :scs (signed-reg) :to :save))
400  (:arg-types unsigned-num signed-num)
401  (:results (result :scs (unsigned-reg)))
402  (:result-types unsigned-num)
403  (:translate ash)
404  (:policy :fast-safe)
405  (:temporary (:sc non-descriptor-reg) ndesc)
406  (:generator 5
407    (let ((done (gen-label)))
408      (inst cmp amount)
409      (inst b :ge done)
410      ;; The result-type assures us that this shift will not
411      ;; overflow.
412      (inst sll result number amount)
413      (inst neg ndesc amount)
414      (inst cmp ndesc 32)
415      (if (member :sparc-v9 *backend-subfeatures*)
416          (progn
417            (inst srl result number ndesc)
418            (inst cmove :ge result zero-tn))
419          (progn
420            (inst b :lt done)
421            (inst srl result number ndesc)
422            (move result zero-tn)))
423      (emit-label done))))
424
425(define-vop (fast-ash-c/unsigned=>unsigned)
426  (:note "inline constant ASH")
427  (:args (number :scs (unsigned-reg)))
428  (:info count)
429  (:arg-types unsigned-num (:constant integer))
430  (:results (result :scs (unsigned-reg)))
431  (:result-types unsigned-num)
432  (:translate ash)
433  (:policy :fast-safe)
434  (:generator 4
435    (cond
436      ((< count -31) (move result zero-tn))
437      ((< count 0) (inst srl result number (min (- count) 31)))
438      ((> count 0) (inst sll result number (min count 31)))
439      (t (bug "identity ASH not transformed away")))))
440
441;; Some special cases where we know we want a left shift.  Just do the
442;; shift, instead of checking for the sign of the shift.
443(macrolet
444    ((def (name sc-type type result-type cost)
445       `(define-vop (,name)
446         (:note "inline ASH")
447         (:translate ash)
448         (:args (number :scs (,sc-type))
449                (amount :scs (signed-reg unsigned-reg immediate)))
450         (:arg-types ,type positive-fixnum)
451         (:results (result :scs (,result-type)))
452         (:result-types ,type)
453         (:policy :fast-safe)
454         (:generator ,cost
455          ;; The result-type assures us that this shift will not
456          ;; overflow. And for fixnums, the zero bits that get
457          ;; shifted in are just fine for the fixnum tag.
458          (sc-case amount
459           ((signed-reg unsigned-reg)
460            (inst sll result number amount))
461           (immediate
462            (let ((amount (tn-value amount)))
463              (aver (>= amount 0))
464              (inst sll result number amount))))))))
465  (def fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3)
466  (def fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2)
467  (def fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3))
468
469
470(define-vop (signed-byte-32-len)
471  (:translate integer-length)
472  (:note "inline (signed-byte 32) integer-length")
473  (:policy :fast-safe)
474  (:args (arg :scs (signed-reg) :target shift))
475  (:arg-types signed-num)
476  (:results (res :scs (any-reg)))
477  (:result-types positive-fixnum)
478  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
479  (:generator 30
480    (let ((loop (gen-label))
481          (test (gen-label)))
482      (inst addcc shift zero-tn arg)
483      (inst b :ge test)
484      (move res zero-tn)
485      (inst b test)
486      (inst not shift)
487
488      (emit-label loop)
489      (inst add res (fixnumize 1))
490
491      (emit-label test)
492      (inst cmp shift)
493      (inst b :ne loop)
494      (inst srl shift 1))))
495
496(define-vop (unsigned-byte-32-count)
497  (:translate logcount)
498  (:note "inline (unsigned-byte 32) logcount")
499  (:policy :fast-safe)
500  (:args (arg :scs (unsigned-reg)))
501  (:arg-types unsigned-num)
502  (:results (res :scs (unsigned-reg)))
503  (:result-types positive-fixnum)
504  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) mask temp)
505  (:generator 35
506      (move res arg)
507
508      (dolist (stuff '((1 #x55555555) (2 #x33333333) (4 #x0f0f0f0f)
509                       (8 #x00ff00ff) (16 #x0000ffff)))
510        (destructuring-bind (shift bit-mask)
511            stuff
512          ;; Set mask
513          (inst sethi mask (ldb (byte 22 10) bit-mask))
514          (inst add mask (ldb (byte 10 0) bit-mask))
515
516          (inst and temp res mask)
517          (inst srl res shift)
518          (inst and res mask)
519          (inst add res temp)))))
520
521
522;;; Multiply and Divide.
523
524(define-vop (fast-v8-*/fixnum=>fixnum fast-fixnum-binop)
525  (:temporary (:scs (non-descriptor-reg)) temp)
526  (:translate *)
527  (:guard (or (member :sparc-v8 *backend-subfeatures*)
528              (and (member :sparc-v9 *backend-subfeatures*)
529                   (not (member :sparc-64 *backend-subfeatures*)))))
530  (:generator 2
531    ;; The cost here should be less than the cost for
532    ;; */signed=>signed.  Why?  A fixnum product using signed=>signed
533    ;; has to convert both args to signed-nums.  But using this, we
534    ;; don't have to and that saves an instruction.
535    (inst sra temp y n-fixnum-tag-bits)
536    (inst smul r x temp)))
537
538(define-vop (fast-v8-*-c/fixnum=>fixnum fast-safe-arith-op)
539  (:args (x :target r :scs (any-reg zero)))
540  (:info y)
541  (:arg-types tagged-num
542              (:constant (and (signed-byte 13) (not (integer 0 0)))))
543  (:results (r :scs (any-reg)))
544  (:result-types tagged-num)
545  (:note "inline fixnum arithmetic")
546  (:translate *)
547  (:guard (or (member :sparc-v8 *backend-subfeatures*)
548              (and (member :sparc-v9 *backend-subfeatures*)
549                   (not (member :sparc-64 *backend-subfeatures*)))))
550  (:generator 1
551    (inst smul r x y)))
552
553(define-vop (fast-v8-*/signed=>signed fast-signed-binop)
554  (:translate *)
555  (:guard (or (member :sparc-v8 *backend-subfeatures*)
556              (and (member :sparc-v9 *backend-subfeatures*)
557                   (not (member :sparc-64 *backend-subfeatures*)))))
558  (:generator 3
559    (inst smul r x y)))
560
561(define-vop (fast-v8-*-c/signed=>signed fast-signed-binop-c)
562  (:translate *)
563  (:guard (or (member :sparc-v8 *backend-subfeatures*)
564              (and (member :sparc-v9 *backend-subfeatures*)
565                   (not (member :sparc-64 *backend-subfeatures*)))))
566  (:generator 2
567    (inst smul r x y)))
568
569(define-vop (fast-v8-*/unsigned=>unsigned fast-unsigned-binop)
570  (:translate *)
571  (:guard (or (member :sparc-v8 *backend-subfeatures*)
572              (and (member :sparc-v9 *backend-subfeatures*)
573                   (not (member :sparc-64 *backend-subfeatures*)))))
574  (:generator 3
575    (inst umul r x y)))
576
577(define-vop (fast-v8-*-c/unsigned=>unsigned fast-unsigned-binop-c)
578  (:translate *)
579  (:guard (or (member :sparc-v8 *backend-subfeatures*)
580              (and (member :sparc-v9 *backend-subfeatures*)
581                   (not (member :sparc-64 *backend-subfeatures*)))))
582  (:generator 2
583    (inst umul r x y)))
584
585;; The smul and umul instructions are deprecated on the Sparc V9.  Use
586;; mulx instead.
587(define-vop (fast-v9-*/fixnum=>fixnum fast-fixnum-binop)
588  (:temporary (:scs (non-descriptor-reg)) temp)
589  (:translate *)
590  (:guard (member :sparc-64 *backend-subfeatures*))
591  (:generator 4
592    (inst sra temp y n-fixnum-tag-bits)
593    (inst mulx r x temp)))
594
595(define-vop (fast-v9-*/signed=>signed fast-signed-binop)
596  (:translate *)
597  (:guard (member :sparc-64 *backend-subfeatures*))
598  (:generator 3
599    (inst mulx r x y)))
600
601(define-vop (fast-v9-*/unsigned=>unsigned fast-unsigned-binop)
602  (:translate *)
603  (:guard (member :sparc-64 *backend-subfeatures*))
604  (:generator 3
605    (inst mulx r x y)))
606
607
608;;;; Modular functions:
609(define-modular-fun lognot-mod32 (x) lognot :untagged nil 32)
610(define-vop (lognot-mod32/unsigned=>unsigned)
611  (:translate lognot-mod32)
612  (:args (x :scs (unsigned-reg)))
613  (:arg-types unsigned-num)
614  (:results (res :scs (unsigned-reg)))
615  (:result-types unsigned-num)
616  (:policy :fast-safe)
617  (:generator 1
618    (inst not res x)))
619
620(macrolet
621    ((define-modular-backend (fun &optional constantp)
622       (let ((mfun-name (symbolicate fun '-mod32))
623             (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
624             (modcvop (symbolicate 'fast- fun '-mod32-c/unsigned=>unsigned))
625             (vop (symbolicate 'fast- fun '/unsigned=>unsigned))
626             (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
627         `(progn
628            (define-modular-fun ,mfun-name (x y) ,fun :untagged nil 32)
629            (define-vop (,modvop ,vop)
630              (:translate ,mfun-name))
631            ,@(when constantp
632                `((define-vop (,modcvop ,cvop)
633                    (:translate ,mfun-name))))))))
634  (define-modular-backend + t)
635  (define-modular-backend - t)
636  (define-modular-backend logeqv t)
637  (define-modular-backend logandc1)
638  (define-modular-backend logandc2 t)
639  (define-modular-backend logorc1)
640  (define-modular-backend logorc2 t))
641
642(define-source-transform lognand (x y)
643  `(lognot (logand ,x ,y)))
644(define-source-transform lognor (x y)
645  `(lognot (logior ,x ,y)))
646
647(define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
648             fast-ash-c/unsigned=>unsigned)
649  (:translate ash-left-mod32))
650
651(define-vop (fast-ash-left-mod32/unsigned=>unsigned
652             fast-ash-left/unsigned=>unsigned))
653(deftransform ash-left-mod32 ((integer count)
654                              ((unsigned-byte 32) (unsigned-byte 5)))
655  (when (sb!c::constant-lvar-p count)
656    (sb!c::give-up-ir1-transform))
657  '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
658
659;;;; Binary conditional VOPs:
660
661(define-vop (fast-conditional)
662  (:conditional)
663  (:info target not-p)
664  (:effects)
665  (:affected)
666  (:policy :fast-safe))
667
668(define-vop (fast-conditional/fixnum fast-conditional)
669  (:args (x :scs (any-reg zero))
670         (y :scs (any-reg zero)))
671  (:arg-types tagged-num tagged-num)
672  (:note "inline fixnum comparison"))
673
674(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
675  (:args (x :scs (any-reg zero)))
676  (:arg-types tagged-num (:constant (signed-byte 11)))
677  (:info target not-p y))
678
679(define-vop (fast-conditional/signed fast-conditional)
680  (:args (x :scs (signed-reg zero))
681         (y :scs (signed-reg zero)))
682  (:arg-types signed-num signed-num)
683  (:note "inline (signed-byte 32) comparison"))
684
685(define-vop (fast-conditional-c/signed fast-conditional/signed)
686  (:args (x :scs (signed-reg zero)))
687  (:arg-types signed-num (:constant (signed-byte 13)))
688  (:info target not-p y))
689
690(define-vop (fast-conditional/unsigned fast-conditional)
691  (:args (x :scs (unsigned-reg zero))
692         (y :scs (unsigned-reg zero)))
693  (:arg-types unsigned-num unsigned-num)
694  (:note "inline (unsigned-byte 32) comparison"))
695
696(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
697  (:args (x :scs (unsigned-reg zero)))
698  (:arg-types unsigned-num (:constant (unsigned-byte 12)))
699  (:info target not-p y))
700
701
702(defmacro define-conditional-vop (tran cond unsigned not-cond not-unsigned)
703  `(progn
704     ,@(mapcar (lambda (suffix cost signed)
705                 (unless (and (member suffix '(/fixnum -c/fixnum))
706                              (eq tran 'eql))
707                   `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
708                                                  tran suffix))
709                                 ,(intern
710                                   (format nil "~:@(FAST-CONDITIONAL~A~)"
711                                           suffix)))
712                     (:translate ,tran)
713                     (:generator ,cost
714                      (inst cmp x
715                       ,(if (eq suffix '-c/fixnum) '(fixnumize y) 'y))
716                      (inst b (if not-p
717                                  ,(if signed not-cond not-unsigned)
718                                  ,(if signed cond unsigned))
719                       target)
720                      (inst nop)))))
721               '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
722               '(4 3 6 5 6 5)
723               '(t t t t nil nil))))
724
725(define-conditional-vop < :lt :ltu :ge :geu)
726
727(define-conditional-vop > :gt :gtu :le :leu)
728
729(define-conditional-vop eql :eq :eq :ne :ne)
730
731;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
732;;; known fixnum.
733
734;;; These versions specify a fixnum restriction on their first arg.  We have
735;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
736;;; the first arg and a higher cost.  The reason for doing this is to prevent
737;;; fixnum specific operations from being used on word integers, spuriously
738;;; consing the argument.
739;;;
740
741(define-vop (fast-eql/fixnum fast-conditional)
742  (:args (x :scs (any-reg zero))
743         (y :scs (any-reg zero)))
744  (:arg-types tagged-num tagged-num)
745  (:note "inline fixnum comparison")
746  (:translate eql)
747  (:generator 4
748    (inst cmp x y)
749    (inst b (if not-p :ne :eq) target)
750    (inst nop)))
751;;;
752(define-vop (generic-eql/fixnum fast-eql/fixnum)
753  (:args (x :scs (any-reg descriptor-reg))
754         (y :scs (any-reg)))
755  (:arg-types * tagged-num)
756  (:variant-cost 7))
757
758(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
759  (:args (x :scs (any-reg zero)))
760  (:arg-types tagged-num (:constant (signed-byte 11)))
761  (:info target not-p y)
762  (:translate eql)
763  (:generator 2
764    (inst cmp x (fixnumize y))
765    (inst b (if not-p :ne :eq) target)
766    (inst nop)))
767;;;
768(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
769  (:args (x :scs (any-reg descriptor-reg)))
770  (:arg-types * (:constant (signed-byte 11)))
771  (:variant-cost 6))
772
773
774;;;; 32-bit logical operations
775
776(define-vop (shift-towards-someplace)
777  (:policy :fast-safe)
778  (:args (num :scs (unsigned-reg))
779         (amount :scs (signed-reg)))
780  (:arg-types unsigned-num tagged-num)
781  (:results (r :scs (unsigned-reg)))
782  (:result-types unsigned-num))
783
784(define-vop (shift-towards-start shift-towards-someplace)
785  (:translate shift-towards-start)
786  (:note "shift-towards-start")
787  (:generator 1
788    (inst sll r num amount)))
789
790(define-vop (shift-towards-end shift-towards-someplace)
791  (:translate shift-towards-end)
792  (:note "shift-towards-end")
793  (:generator 1
794    (inst srl r num amount)))
795
796;;;; Bignum stuff.
797(define-vop (bignum-length get-header-data)
798  (:translate sb!bignum:%bignum-length)
799  (:policy :fast-safe))
800
801(define-vop (bignum-set-length set-header-data)
802  (:translate sb!bignum:%bignum-set-length)
803  (:policy :fast-safe))
804
805(define-vop (bignum-ref word-index-ref)
806  (:variant bignum-digits-offset other-pointer-lowtag)
807  (:translate sb!bignum:%bignum-ref)
808  (:results (value :scs (unsigned-reg)))
809  (:result-types unsigned-num))
810
811(define-vop (bignum-set word-index-set)
812  (:variant bignum-digits-offset other-pointer-lowtag)
813  (:translate sb!bignum:%bignum-set)
814  (:args (object :scs (descriptor-reg))
815         (index :scs (any-reg immediate zero))
816         (value :scs (unsigned-reg)))
817  (:arg-types t positive-fixnum unsigned-num)
818  (:results (result :scs (unsigned-reg)))
819  (:result-types unsigned-num))
820
821(define-vop (digit-0-or-plus)
822  (:translate sb!bignum:%digit-0-or-plusp)
823  (:policy :fast-safe)
824  (:args (digit :scs (unsigned-reg)))
825  (:arg-types unsigned-num)
826  (:results (result :scs (descriptor-reg)))
827  (:guard (not (member :sparc-v9 *backend-subfeatures*)))
828  (:generator 3
829    (let ((done (gen-label)))
830      (inst cmp digit)
831      (inst b :lt done)
832      (move result null-tn)
833      (load-symbol result t)
834      (emit-label done))))
835
836(define-vop (v9-digit-0-or-plus-cmove)
837  (:translate sb!bignum:%digit-0-or-plusp)
838  (:policy :fast-safe)
839  (:args (digit :scs (unsigned-reg)))
840  (:arg-types unsigned-num)
841  (:results (result :scs (descriptor-reg)))
842  (:guard (member :sparc-v9 *backend-subfeatures*))
843  (:generator 3
844    (inst cmp digit)
845    (load-symbol result t)
846    (inst cmove :lt result null-tn)))
847
848;; This doesn't work?
849#+nil
850(define-vop (v9-digit-0-or-plus-movr)
851  (:translate sb!bignum:%digit-0-or-plusp)
852  (:policy :fast-safe)
853  (:args (digit :scs (unsigned-reg)))
854  (:arg-types unsigned-num)
855  (:results (result :scs (descriptor-reg)))
856  (:temporary (:scs (descriptor-reg)) temp)
857  (:guard #!+:sparc-v9 t #!-:sparc-v9 nil)
858  (:generator 2
859    (load-symbol temp t)
860    (inst movr result null-tn digit :lz)
861    (inst movr result temp digit :gez)))
862
863(define-vop (add-w/carry)
864  (:translate sb!bignum:%add-with-carry)
865  (:policy :fast-safe)
866  (:args (a :scs (unsigned-reg))
867         (b :scs (unsigned-reg))
868         (c :scs (any-reg)))
869  (:arg-types unsigned-num unsigned-num positive-fixnum)
870  (:results (result :scs (unsigned-reg))
871            (carry :scs (unsigned-reg)))
872  (:result-types unsigned-num positive-fixnum)
873  (:generator 3
874    (inst addcc zero-tn c -1)
875    (inst addxcc result a b)
876    (inst addx carry zero-tn zero-tn)))
877
878(define-vop (sub-w/borrow)
879  (:translate sb!bignum:%subtract-with-borrow)
880  (:policy :fast-safe)
881  (:args (a :scs (unsigned-reg))
882         (b :scs (unsigned-reg))
883         (c :scs (any-reg)))
884  (:arg-types unsigned-num unsigned-num positive-fixnum)
885  (:results (result :scs (unsigned-reg))
886            (borrow :scs (unsigned-reg)))
887  (:result-types unsigned-num positive-fixnum)
888  (:generator 4
889    (inst subcc zero-tn c 1)
890    (inst subxcc result a b)
891    (inst addx borrow zero-tn zero-tn)
892    (inst xor borrow 1)))
893
894;;; EMIT-MULTIPLY -- This is used both for bignum stuff and in assembly
895;;; routines.
896;;;
897(defun emit-multiply (multiplier multiplicand result-high result-low)
898  "Emit code to multiply MULTIPLIER with MULTIPLICAND, putting the result
899  in RESULT-HIGH and RESULT-LOW.  KIND is either :signed or :unsigned.
900  Note: the lifetimes of MULTIPLICAND and RESULT-HIGH overlap."
901  (declare (type tn multiplier result-high result-low)
902           (type (or tn (signed-byte 13)) multiplicand))
903  ;; It seems that emit-multiply is only used to do an unsigned
904  ;; multiply, so the code only does an unsigned multiply.
905  (cond
906    ((member :sparc-64 *backend-subfeatures*)
907     ;; Take advantage of V9's 64-bit multiplier.
908     ;;
909     ;; Make sure the multiplier and multiplicand are really
910     ;; unsigned 64-bit numbers.
911     (inst srl multiplier 0)
912     (inst srl multiplicand 0)
913
914     ;; Multiply the two numbers and put the result in
915     ;; result-high.  Copy the low 32-bits to result-low.  Then
916     ;; shift result-high so the high 32-bits end up in the low
917     ;; 32-bits.
918     (inst mulx result-high multiplier multiplicand)
919     (inst move result-low result-high)
920     (inst srax result-high 32))
921    ((or (member :sparc-v8 *backend-subfeatures*)
922         (member :sparc-v9 *backend-subfeatures*))
923     ;; V8 has a multiply instruction.  This should also work for
924     ;; the V9, but umul and the Y register is deprecated on the
925     ;; V9.
926     (inst umul result-low multiplier multiplicand)
927     (inst rdy result-high))
928    (t
929     (let ((label (gen-label)))
930       (inst wry multiplier)
931       (inst andcc result-high zero-tn)
932       ;; Note: we can't use the Y register until three insts
933       ;; after it's written.
934       (inst nop)
935       (inst nop)
936       (dotimes (i 32)
937         (inst mulscc result-high multiplicand))
938       (inst mulscc result-high zero-tn)
939       (inst cmp multiplicand)
940       (inst b :ge label)
941       (inst nop)
942       (inst add result-high multiplier)
943       (emit-label label)
944       (inst rdy result-low)))))
945
946(define-vop (bignum-mult-and-add-3-arg)
947  (:translate sb!bignum:%multiply-and-add)
948  (:policy :fast-safe)
949  (:args (x :scs (unsigned-reg) :to (:eval 1))
950         (y :scs (unsigned-reg) :to (:eval 1))
951         (carry-in :scs (unsigned-reg) :to (:eval 2)))
952  (:arg-types unsigned-num unsigned-num unsigned-num)
953  (:results (hi :scs (unsigned-reg) :from (:eval 0))
954            (lo :scs (unsigned-reg) :from (:eval 1)))
955  (:result-types unsigned-num unsigned-num)
956  (:generator 40
957    (emit-multiply x y hi lo)
958    (inst addcc lo carry-in)
959    (inst addx hi zero-tn)))
960
961(define-vop (bignum-mult-and-add-4-arg)
962  (:translate sb!bignum:%multiply-and-add)
963  (:policy :fast-safe)
964  (:args (x :scs (unsigned-reg) :to (:eval 1))
965         (y :scs (unsigned-reg) :to (:eval 1))
966         (prev :scs (unsigned-reg) :to (:eval 2))
967         (carry-in :scs (unsigned-reg) :to (:eval 2)))
968  (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
969  (:results (hi :scs (unsigned-reg) :from (:eval 0))
970            (lo :scs (unsigned-reg) :from (:eval 1)))
971  (:result-types unsigned-num unsigned-num)
972  (:generator 40
973    (emit-multiply x y hi lo)
974    (inst addcc lo carry-in)
975    (inst addx hi zero-tn)
976    (inst addcc lo prev)
977    (inst addx hi zero-tn)))
978
979(define-vop (bignum-mult)
980  (:translate sb!bignum:%multiply)
981  (:policy :fast-safe)
982  (:args (x :scs (unsigned-reg) :to (:result 1))
983         (y :scs (unsigned-reg) :to (:result 1)))
984  (:arg-types unsigned-num unsigned-num)
985  (:results (hi :scs (unsigned-reg))
986            (lo :scs (unsigned-reg)))
987  (:result-types unsigned-num unsigned-num)
988  (:generator 40
989    (emit-multiply x y hi lo)))
990
991(define-vop (bignum-lognot lognot-mod32/unsigned=>unsigned)
992  (:translate sb!bignum:%lognot))
993
994(define-vop (fixnum-to-digit)
995  (:translate sb!bignum:%fixnum-to-digit)
996  (:policy :fast-safe)
997  (:args (fixnum :scs (any-reg)))
998  (:arg-types tagged-num)
999  (:results (digit :scs (unsigned-reg)))
1000  (:result-types unsigned-num)
1001  (:generator 1
1002    (inst sra digit fixnum n-fixnum-tag-bits)))
1003
1004(define-vop (bignum-floor)
1005  (:translate sb!bignum:%bigfloor)
1006  (:policy :fast-safe)
1007  (:args (div-high :scs (unsigned-reg) :target rem)
1008         (div-low :scs (unsigned-reg) :target quo)
1009         (divisor :scs (unsigned-reg)))
1010  (:arg-types unsigned-num unsigned-num unsigned-num)
1011  (:results (quo :scs (unsigned-reg) :from (:argument 1))
1012            (rem :scs (unsigned-reg) :from (:argument 0)))
1013  (:result-types unsigned-num unsigned-num)
1014  (:generator 300
1015    (move rem div-high)
1016    (move quo div-low)
1017    (dotimes (i 33)
1018      (let ((label (gen-label)))
1019        (inst cmp rem divisor)
1020        (inst b :ltu label)
1021        (inst addxcc quo quo)
1022        (inst sub rem divisor)
1023        (emit-label label)
1024        (unless (= i 32)
1025          (inst addx rem rem))))
1026    (inst not quo)))
1027
1028(define-vop (bignum-floor-v8)
1029  (:translate sb!bignum:%bigfloor)
1030  (:policy :fast-safe)
1031  (:args (div-high :scs (unsigned-reg) :target rem)
1032         (div-low :scs (unsigned-reg) :target quo)
1033         (divisor :scs (unsigned-reg)))
1034  (:arg-types unsigned-num unsigned-num unsigned-num)
1035  (:results (quo :scs (unsigned-reg) :from (:argument 1))
1036            (rem :scs (unsigned-reg) :from (:argument 0)))
1037  (:result-types unsigned-num unsigned-num)
1038  (:temporary (:scs (unsigned-reg) :target quo) q)
1039  ;; This vop is for a v8 or v9, provided we're also not using
1040  ;; sparc-64, for which there a special sparc-64 vop.
1041  (:guard (or (member :sparc-v8 *backend-subfeatures*)
1042              (member :sparc-v9 *backend-subfeatures*)))
1043  (:generator 15
1044    (inst wry div-high)
1045    (inst nop)
1046    (inst nop)
1047    (inst nop)
1048    ;; Compute the quotient [Y, div-low] / divisor
1049    (inst udiv q div-low divisor)
1050    ;; Compute the remainder.  The high part of the result is in the Y
1051    ;; register.
1052    (inst umul rem q divisor)
1053    (inst sub rem div-low rem)
1054    (unless (location= quo q)
1055      (move quo q))))
1056
1057(define-vop (bignum-floor-v9)
1058  (:translate sb!bignum:%bigfloor)
1059  (:policy :fast-safe)
1060  (:args (div-high :scs (unsigned-reg))
1061         (div-low :scs (unsigned-reg))
1062         (divisor :scs (unsigned-reg) :to (:result 1)))
1063  (:arg-types unsigned-num unsigned-num unsigned-num)
1064  (:temporary (:sc unsigned-reg :from (:argument 0)) dividend)
1065  (:results (quo :scs (unsigned-reg))
1066            (rem :scs (unsigned-reg)))
1067  (:result-types unsigned-num unsigned-num)
1068  (:guard (member :sparc-64 *backend-subfeatures*))
1069  (:generator 5
1070    ;; Set dividend to be div-high and div-low
1071    (inst sllx dividend div-high 32)
1072    (inst add dividend div-low)
1073    ;; Compute quotient
1074    (inst udivx quo dividend divisor)
1075    ;; Compute the remainder
1076    (inst mulx rem quo divisor)
1077    (inst sub rem dividend rem)))
1078
1079(define-vop (signify-digit)
1080  (:translate sb!bignum:%fixnum-digit-with-correct-sign)
1081  (:policy :fast-safe)
1082  (:args (digit :scs (unsigned-reg) :target res))
1083  (:arg-types unsigned-num)
1084  (:results (res :scs (any-reg signed-reg)))
1085  (:result-types signed-num)
1086  (:generator 1
1087    (sc-case res
1088      (any-reg
1089       (inst sll res digit n-fixnum-tag-bits))
1090      (signed-reg
1091       (move res digit)))))
1092
1093(define-vop (digit-ashr)
1094  (:translate sb!bignum:%ashr)
1095  (:policy :fast-safe)
1096  (:args (digit :scs (unsigned-reg))
1097         (count :scs (unsigned-reg)))
1098  (:arg-types unsigned-num positive-fixnum)
1099  (:results (result :scs (unsigned-reg)))
1100  (:result-types unsigned-num)
1101  (:generator 1
1102    (inst sra result digit count)))
1103
1104(define-vop (digit-lshr digit-ashr)
1105  (:translate sb!bignum:%digit-logical-shift-right)
1106  (:generator 1
1107    (inst srl result digit count)))
1108
1109(define-vop (digit-ashl digit-ashr)
1110  (:translate sb!bignum:%ashl)
1111  (:generator 1
1112    (inst sll result digit count)))
1113
1114
1115;;;; Static functions.
1116
1117(define-static-fun two-arg-gcd (x y) :translate gcd)
1118(define-static-fun two-arg-lcm (x y) :translate lcm)
1119
1120(define-static-fun two-arg-+ (x y) :translate +)
1121(define-static-fun two-arg-- (x y) :translate -)
1122(define-static-fun two-arg-* (x y) :translate *)
1123(define-static-fun two-arg-/ (x y) :translate /)
1124
1125(define-static-fun two-arg-< (x y) :translate <)
1126(define-static-fun two-arg-<= (x y) :translate <=)
1127(define-static-fun two-arg-> (x y) :translate >)
1128(define-static-fun two-arg->= (x y) :translate >=)
1129(define-static-fun two-arg-= (x y) :translate =)
1130(define-static-fun two-arg-/= (x y) :translate /=)
1131
1132(define-static-fun %negate (x) :translate %negate)
1133
1134(define-static-fun two-arg-and (x y) :translate logand)
1135(define-static-fun two-arg-ior (x y) :translate logior)
1136(define-static-fun two-arg-xor (x y) :translate logxor)
1137(define-static-fun two-arg-eqv (x y) :translate logeqv)
1138
1139
1140(in-package "SB!C")
1141
1142(deftransform * ((x y)
1143                 ((unsigned-byte 32) (constant-arg (unsigned-byte 32)))
1144                 (unsigned-byte 32))
1145  "recode as shifts and adds"
1146  (let ((y (lvar-value y)))
1147    (multiple-value-bind (result adds shifts)
1148        (ub32-strength-reduce-constant-multiply 'x y)
1149      (cond
1150        ;; we assume, perhaps foolishly, that good SPARCs don't have an
1151        ;; issue with multiplications.  (Remember that there's a
1152        ;; different transform for converting x*2^k to a shift).
1153        ((member :sparc-64 *backend-subfeatures*) (give-up-ir1-transform))
1154        ((or (member :sparc-v9 *backend-subfeatures*)
1155             (member :sparc-v8 *backend-subfeatures*))
1156         ;; breakeven point as measured by Raymond Toy
1157         (when (> (+ adds shifts) 9)
1158           (give-up-ir1-transform))))
1159      (or result 0))))
1160