1.0.9.52: copy propagation interfering with local calls
[sbcl.git] / src / compiler / hppa / arith.lisp
1 ;;;; the VM definition arithmetic VOPs for HPPA
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 ;;;; Unary operations.
15
16 (define-vop (fixnum-unop)
17   (:args (x :scs (any-reg)))
18   (:results (res :scs (any-reg)))
19   (:note "inline fixnum arithmetic")
20   (:arg-types tagged-num)
21   (:result-types tagged-num)
22   (:policy :fast-safe))
23
24 (define-vop (signed-unop)
25   (:args (x :scs (signed-reg)))
26   (:results (res :scs (signed-reg)))
27   (:note "inline (signed-byte 32) arithmetic")
28   (:arg-types signed-num)
29   (:result-types signed-num)
30   (:policy :fast-safe))
31
32 (define-vop (fast-negate/fixnum fixnum-unop)
33   (:translate %negate)
34   (:generator 1
35     (inst sub zero-tn x res)))
36
37 (define-vop (fast-negate/signed signed-unop)
38   (:translate %negate)
39   (:generator 2
40     (inst sub zero-tn x res)))
41
42 (define-vop (fast-lognot/fixnum fixnum-unop)
43   (:temporary (:scs (any-reg) :type fixnum :to (:result 0))
44               temp)
45   (:translate lognot)
46   (:generator 2
47     (inst li (fixnumize -1) temp)
48     (inst xor x temp res)))
49
50 (define-vop (fast-lognot/signed signed-unop)
51   (:translate lognot)
52   (:generator 1
53     (inst uaddcm zero-tn x res)))
54 \f
55 ;;;; Binary fixnum operations.
56
57 ;;; Assume that any constant operand is the second arg...
58
59 (define-vop (fast-fixnum-binop)
60   (:args (x :target r :scs (any-reg))
61          (y :target r :scs (any-reg)))
62   (:arg-types tagged-num tagged-num)
63   (:results (r :scs (any-reg)))
64   (:result-types tagged-num)
65   (:note "inline fixnum arithmetic")
66   (:effects)
67   (:affected)
68   (:policy :fast-safe))
69
70 (define-vop (fast-unsigned-binop)
71   (:args (x :target r :scs (unsigned-reg))
72          (y :target r :scs (unsigned-reg)))
73   (:arg-types unsigned-num unsigned-num)
74   (:results (r :scs (unsigned-reg)))
75   (:result-types unsigned-num)
76   (:note "inline (unsigned-byte 32) arithmetic")
77   (:effects)
78   (:affected)
79   (:policy :fast-safe))
80
81 (define-vop (fast-signed-binop)
82   (:args (x :target r :scs (signed-reg))
83          (y :target r :scs (signed-reg)))
84   (:arg-types signed-num signed-num)
85   (:results (r :scs (signed-reg)))
86   (:result-types signed-num)
87   (:note "inline (signed-byte 32) arithmetic")
88   (:effects)
89   (:affected)
90   (:policy :fast-safe))
91
92 (defmacro define-binop (translate cost untagged-cost op &optional arg-swap)
93   `(progn
94      (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
95                   fast-fixnum-binop)
96        (:args (x :target r :scs (any-reg))
97               (y :target r :scs (any-reg)))
98        (:translate ,translate)
99        (:generator ,cost
100          ,(if arg-swap
101               `(inst ,op y x r)
102               `(inst ,op x y r))))
103      (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
104                   fast-signed-binop)
105        (:args (x :target r :scs (signed-reg))
106               (y :target r :scs (signed-reg)))
107        (:translate ,translate)
108        (:generator ,untagged-cost
109          ,(if arg-swap
110               `(inst ,op y x r)
111               `(inst ,op x y r))))
112      (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
113                   fast-unsigned-binop)
114        (:args (x :target r :scs (unsigned-reg))
115               (y :target r :scs (unsigned-reg)))
116        (:translate ,translate)
117        (:generator ,untagged-cost
118          ,(if arg-swap
119               `(inst ,op y x r)
120               `(inst ,op x y r))))))
121
122 (define-binop + 2 6 add)
123 (define-binop - 2 6 sub)
124 (define-binop logior 1 2 or)
125 (define-binop logand 1 2 and)
126 (define-binop logandc1 1 2 andcm t)
127 (define-binop logandc2 1 2 andcm)
128 (define-binop logxor 1 2 xor)
129
130 (define-vop (fast-fixnum-c-binop fast-fixnum-binop)
131   (:args (x :target r :scs (any-reg)))
132   (:info y)
133   (:arg-types tagged-num (:constant integer)))
134
135 (define-vop (fast-signed-c-binop fast-signed-binop)
136   (:args (x :target r :scs (signed-reg)))
137   (:info y)
138   (:arg-types tagged-num (:constant integer)))
139
140 (define-vop (fast-unsigned-c-binop fast-unsigned-binop)
141   (:args (x :target r :scs (unsigned-reg)))
142   (:info y)
143   (:arg-types tagged-num (:constant integer)))
144
145 (defmacro define-c-binop (translate cost untagged-cost tagged-type
146                                     untagged-type inst)
147   `(progn
148      (define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
149                   fast-fixnum-c-binop)
150        (:arg-types tagged-num (:constant ,tagged-type))
151        (:translate ,translate)
152        (:generator ,cost
153          (let ((y (fixnumize y)))
154            ,inst)))
155      (define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
156                   fast-signed-c-binop)
157        (:arg-types signed-num (:constant ,untagged-type))
158        (:translate ,translate)
159        (:generator ,untagged-cost
160          ,inst))
161      (define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED=>UNSIGNED")
162                   fast-unsigned-c-binop)
163        (:arg-types unsigned-num (:constant ,untagged-type))
164        (:translate ,translate)
165        (:generator ,untagged-cost
166          ,inst))))
167
168 (define-c-binop + 1 3 (signed-byte 9) (signed-byte 11)
169   (inst addi y x r))
170 (define-c-binop - 1 3
171   (integer #.(- (1- (ash 1 9))) #.(ash 1 9))
172   (integer #.(- (1- (ash 1 11))) #.(ash 1 11))
173   (inst addi (- y) x r))
174
175 ;;; Special case fixnum + and - that trap on overflow.  Useful when we don't
176 ;;; know that the result is going to be a fixnum.
177
178 (define-vop (fast-+/fixnum fast-+/fixnum=>fixnum)
179   (:results (r :scs (any-reg descriptor-reg)))
180   (:result-types (:or signed-num unsigned-num))
181   (:note nil)
182   (:generator 4
183     (inst addo x y r)))
184
185 (define-vop (fast-+-c/fixnum fast-+-c/fixnum=>fixnum)
186   (:results (r :scs (any-reg descriptor-reg)))
187   (:result-types (:or signed-num unsigned-num))
188   (:note nil)
189   (:generator 3
190     (inst addio (fixnumize y) x r)))
191
192 (define-vop (fast--/fixnum fast--/fixnum=>fixnum)
193   (:results (r :scs (any-reg descriptor-reg)))
194   (:result-types (:or signed-num unsigned-num))
195   (:note nil)
196   (:generator 4
197     (inst subo x y r)))
198
199 (define-vop (fast---c/fixnum fast---c/fixnum=>fixnum)
200   (:results (r :scs (any-reg descriptor-reg)))
201   (:result-types (:or signed-num unsigned-num))
202   (:note nil)
203   (:generator 3
204     (inst addio (- (fixnumize y)) x r)))
205
206 ;;; Shifting
207
208 (define-vop (fast-ash/unsigned=>unsigned)
209   (:policy :fast-safe)
210   (:translate ash)
211   (:note "inline word ASH")
212   (:args (number :scs (unsigned-reg))
213          (count :scs (signed-reg)))
214   (:arg-types unsigned-num tagged-num)
215   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
216   (:results (result :scs (unsigned-reg)))
217   (:result-types unsigned-num)
218   (:generator 8
219     (inst comb :>= count zero-tn positive :nullify t)
220     (inst sub zero-tn count temp)
221     (inst comiclr 31 temp zero-tn :>=)
222     (inst li 31 temp)
223     (inst mtctl temp :sar)
224     (inst extrs number 0 1 temp)
225     (inst b done)
226     (inst shd temp number :variable result)
227     POSITIVE
228     (inst subi 31 count temp)
229     (inst mtctl temp :sar)
230     (inst zdep number :variable 32 result)
231     DONE))
232
233 (define-vop (fast-ash/signed=>signed)
234   (:policy :fast-safe)
235   (:translate ash)
236   (:note "inline word ASH")
237   (:args (number :scs (signed-reg))
238          (count :scs (signed-reg)))
239   (:arg-types signed-num tagged-num)
240   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
241   (:results (result :scs (signed-reg)))
242   (:result-types signed-num)
243   (:generator 8
244     (inst comb :>= count zero-tn positive :nullify t)
245     (inst sub zero-tn count temp)
246     (inst comiclr 31 temp zero-tn :>=)
247     (inst li 31 temp)
248     (inst mtctl temp :sar)
249     (inst extrs number 0 1 temp)
250     (inst b done)
251     (inst shd temp number :variable result)
252     POSITIVE
253     (inst subi 31 count temp)
254     (inst mtctl temp :sar)
255     (inst zdep number :variable 32 result)
256     DONE))
257
258 (define-vop (fast-ash-c/unsigned=>unsigned)
259   (:policy :fast-safe)
260   (:translate ash)
261   (:note nil)
262   (:args (number :scs (unsigned-reg)))
263   (:info count)
264   (:arg-types unsigned-num (:constant integer))
265   (:results (result :scs (unsigned-reg)))
266   (:result-types unsigned-num)
267   (:generator 1
268     (cond ((< count 0)
269            ;; It is a right shift.
270            (inst srl number (min (- count) 31) result))
271           ((> count 0)
272            ;; It is a left shift.
273            (inst sll number (min count 31) result))
274           (t
275            ;; Count=0?  Shouldn't happen, but it's easy:
276            (move number result)))))
277
278 (define-vop (fast-ash-c/signed=>signed)
279   (:policy :fast-safe)
280   (:translate ash)
281   (:note nil)
282   (:args (number :scs (signed-reg)))
283   (:info count)
284   (:arg-types signed-num (:constant integer))
285   (:results (result :scs (signed-reg)))
286   (:result-types signed-num)
287   (:generator 1
288     (cond ((< count 0)
289            ;; It is a right shift.
290            (inst sra number (min (- count) 31) result))
291           ((> count 0)
292            ;; It is a left shift.
293            (inst sll number (min count 31) result))
294           (t
295            ;; Count=0?  Shouldn't happen, but it's easy:
296            (move number result)))))
297
298 ;;; FIXME: implement FAST-ASH-LEFT/UNSIGNED=>UNSIGNED and friends, for
299 ;;; use in modular ASH (and because they're useful anyway).  -- CSR,
300 ;;; 2004-08-16
301
302 (define-vop (signed-byte-32-len)
303   (:translate integer-length)
304   (:note "inline (signed-byte 32) integer-length")
305   (:policy :fast-safe)
306   (:args (arg :scs (signed-reg) :target shift))
307   (:arg-types signed-num)
308   (:results (res :scs (any-reg)))
309   (:result-types positive-fixnum)
310   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
311   (:generator 30
312     (inst move arg shift :>=)
313     (inst uaddcm zero-tn shift shift)
314     (inst comb := shift zero-tn done)
315     (inst li 0 res)
316     LOOP
317     (inst srl shift 1 shift)
318     (inst comb :<> shift zero-tn loop)
319     (inst addi (fixnumize 1) res res)
320     DONE))
321
322 (define-vop (unsigned-byte-32-count)
323   (:translate logcount)
324   (:note "inline (unsigned-byte 32) logcount")
325   (:policy :fast-safe)
326   (:args (arg :scs (unsigned-reg) :target num))
327   (:arg-types unsigned-num)
328   (:results (res :scs (unsigned-reg)))
329   (:result-types positive-fixnum)
330   (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0)
331                     :target res) num)
332   (:temporary (:scs (non-descriptor-reg)) mask temp)
333   (:generator 30
334     (inst li #x55555555 mask)
335     (inst srl arg 1 temp)
336     (inst and arg mask num)
337     (inst and temp mask temp)
338     (inst add num temp num)
339     (inst li #x33333333 mask)
340     (inst srl num 2 temp)
341     (inst and num mask num)
342     (inst and temp mask temp)
343     (inst add num temp num)
344     (inst li #x0f0f0f0f mask)
345     (inst srl num 4 temp)
346     (inst and num mask num)
347     (inst and temp mask temp)
348     (inst add num temp num)
349     (inst li #x00ff00ff mask)
350     (inst srl num 8 temp)
351     (inst and num mask num)
352     (inst and temp mask temp)
353     (inst add num temp num)
354     (inst li #x0000ffff mask)
355     (inst srl num 16 temp)
356     (inst and num mask num)
357     (inst and temp mask temp)
358     (inst add num temp res)))
359
360 ;;; Multiply and Divide.
361
362 (define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
363   (:args (x :scs (any-reg) :target x-pass)
364          (y :scs (any-reg) :target y-pass))
365   (:temporary (:sc signed-reg :offset nl0-offset
366                    :from (:argument 0) :to (:result 0)) x-pass)
367   (:temporary (:sc signed-reg :offset nl1-offset
368                    :from (:argument 1) :to (:result 0)) y-pass)
369   (:temporary (:sc signed-reg :offset nl2-offset :target r
370                    :from (:argument 1) :to (:result 0)) res-pass)
371   (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp)
372   (:temporary (:sc signed-reg :offset nl4-offset
373                    :from (:argument 1) :to (:result 0)) sign)
374   (:temporary (:sc interior-reg :offset lip-offset) lip)
375   (:ignore lip sign)
376   (:translate *)
377   (:generator 30
378     (unless (location= y y-pass)
379       (inst sra x 2 x-pass))
380     (let ((fixup (make-fixup 'multiply :assembly-routine)))
381       (inst ldil fixup tmp)
382       (inst ble fixup lisp-heap-space tmp))
383     (if (location= y y-pass)
384         (inst sra x 2 x-pass)
385         (inst move y y-pass))
386     (move res-pass r)))
387
388 (define-vop (fast-*/signed=>signed fast-signed-binop)
389   (:translate *)
390   (:args (x :scs (signed-reg) :target x-pass)
391          (y :scs (signed-reg) :target y-pass))
392   (:temporary (:sc signed-reg :offset nl0-offset
393                    :from (:argument 0) :to (:result 0)) x-pass)
394   (:temporary (:sc signed-reg :offset nl1-offset
395                    :from (:argument 1) :to (:result 0)) y-pass)
396   (:temporary (:sc signed-reg :offset nl2-offset :target r
397                    :from (:argument 1) :to (:result 0)) res-pass)
398   (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp)
399   (:temporary (:sc signed-reg :offset nl4-offset
400                    :from (:argument 1) :to (:result 0)) sign)
401   (:temporary (:sc interior-reg :offset lip-offset) lip)
402   (:ignore lip sign)
403   (:translate *)
404   (:generator 31
405     (let ((fixup (make-fixup 'multiply :assembly-routine)))
406       (move x x-pass)
407       (move y y-pass)
408       (inst ldil fixup tmp)
409       (inst ble fixup lisp-heap-space tmp :nullify t)
410       (inst nop)
411       (move res-pass r))))
412
413 (define-vop (fast-truncate/fixnum fast-fixnum-binop)
414   (:translate truncate)
415   (:args (x :scs (any-reg) :target x-pass)
416          (y :scs (any-reg) :target y-pass))
417   (:temporary (:sc signed-reg :offset nl0-offset
418                    :from (:argument 0) :to (:result 0)) x-pass)
419   (:temporary (:sc signed-reg :offset nl1-offset
420                    :from (:argument 1) :to (:result 0)) y-pass)
421   (:temporary (:sc signed-reg :offset nl2-offset :target q
422                    :from (:argument 1) :to (:result 0)) q-pass)
423   (:temporary (:sc signed-reg :offset nl3-offset :target r
424                    :from (:argument 1) :to (:result 1)) r-pass)
425   (:results (q :scs (signed-reg))
426             (r :scs (any-reg)))
427   (:result-types tagged-num tagged-num)
428   (:vop-var vop)
429   (:save-p :compute-only)
430   (:generator 30
431     (let ((zero (generate-error-code vop division-by-zero-error x y)))
432       (inst bc := nil y zero-tn zero))
433     (move x x-pass)
434     (move y y-pass)
435     (let ((fixup (make-fixup 'truncate :assembly-routine)))
436       (inst ldil fixup q-pass)
437       (inst ble fixup lisp-heap-space q-pass :nullify t))
438     (inst nop)
439     (move q-pass q)
440     (move r-pass r)))
441
442 (define-vop (fast-truncate/signed fast-signed-binop)
443   (:translate truncate)
444   (:args (x :scs (signed-reg) :target x-pass)
445          (y :scs (signed-reg) :target y-pass))
446   (:temporary (:sc signed-reg :offset nl0-offset
447                    :from (:argument 0) :to (:result 0)) x-pass)
448   (:temporary (:sc signed-reg :offset nl1-offset
449                    :from (:argument 1) :to (:result 0)) y-pass)
450   (:temporary (:sc signed-reg :offset nl2-offset :target q
451                    :from (:argument 1) :to (:result 0)) q-pass)
452   (:temporary (:sc signed-reg :offset nl3-offset :target r
453                    :from (:argument 1) :to (:result 1)) r-pass)
454   (:results (q :scs (signed-reg))
455             (r :scs (signed-reg)))
456   (:result-types signed-num signed-num)
457   (:vop-var vop)
458   (:save-p :compute-only)
459   (:generator 35
460     (let ((zero (generate-error-code vop division-by-zero-error x y)))
461       (inst bc := nil y zero-tn zero))
462     (move x x-pass)
463     (move y y-pass)
464     (let ((fixup (make-fixup 'truncate :assembly-routine)))
465       (inst ldil fixup q-pass)
466       (inst ble fixup lisp-heap-space q-pass :nullify t))
467     (inst nop)
468     (move q-pass q)
469     (move r-pass r)))
470
471 \f
472 ;;;; Binary conditional VOPs:
473
474 (define-vop (fast-conditional)
475   (:conditional)
476   (:info target not-p)
477   (:effects)
478   (:affected)
479   (:policy :fast-safe))
480
481 (define-vop (fast-conditional/fixnum fast-conditional)
482   (:args (x :scs (any-reg))
483          (y :scs (any-reg)))
484   (:arg-types tagged-num tagged-num)
485   (:note "inline fixnum comparison"))
486
487 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
488   (:args (x :scs (any-reg)))
489   (:arg-types tagged-num (:constant (signed-byte 9)))
490   (:info target not-p y))
491
492 (define-vop (fast-conditional/signed fast-conditional)
493   (:args (x :scs (signed-reg))
494          (y :scs (signed-reg)))
495   (:arg-types signed-num signed-num)
496   (:note "inline (signed-byte 32) comparison"))
497
498 (define-vop (fast-conditional-c/signed fast-conditional/signed)
499   (:args (x :scs (signed-reg)))
500   (:arg-types signed-num (:constant (signed-byte 11)))
501   (:info target not-p y))
502
503 (define-vop (fast-conditional/unsigned fast-conditional)
504   (:args (x :scs (unsigned-reg))
505          (y :scs (unsigned-reg)))
506   (:arg-types unsigned-num unsigned-num)
507   (:note "inline (unsigned-byte 32) comparison"))
508
509 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
510   (:args (x :scs (unsigned-reg)))
511   (:arg-types unsigned-num (:constant (signed-byte 11)))
512   (:info target not-p y))
513
514
515 (defmacro define-conditional-vop (translate signed-cond unsigned-cond)
516   `(progn
517      ,@(mapcar #'(lambda (suffix cost signed imm)
518                    (unless (and (member suffix '(/fixnum -c/fixnum))
519                                 (eq translate 'eql))
520                      `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
521                                                     translate suffix))
522                                    ,(intern
523                                      (format nil "~:@(FAST-CONDITIONAL~A~)"
524                                              suffix)))
525                         (:translate ,translate)
526                         (:generator ,cost
527                           (inst ,(if imm 'bci 'bc)
528                                 ,(if signed signed-cond unsigned-cond)
529                                 not-p
530                                 ,(if (eq suffix '-c/fixnum)
531                                      '(fixnumize y)
532                                      'y)
533                                 x
534                                 target)))))
535                '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
536                '(3 2 5 4 5 4)
537                '(t t t t nil nil)
538                '(nil t nil t nil t))))
539
540 ;; We switch < and > because the immediate has to come first.
541
542 (define-conditional-vop < :> :>>)
543 (define-conditional-vop > :< :<<)
544
545 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
546 ;;; known fixnum.
547 ;;;
548 (define-conditional-vop eql := :=)
549
550 ;;; These versions specify a fixnum restriction on their first arg.  We have
551 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
552 ;;; the first arg and a higher cost.  The reason for doing this is to prevent
553 ;;; fixnum specific operations from being used on word integers, spuriously
554 ;;; consing the argument.
555 ;;;
556 (define-vop (fast-eql/fixnum fast-conditional)
557   (:args (x :scs (any-reg descriptor-reg))
558          (y :scs (any-reg)))
559   (:arg-types tagged-num tagged-num)
560   (:note "inline fixnum comparison")
561   (:translate eql)
562   (:generator 3
563     (inst bc := not-p x y target)))
564 ;;;
565 (define-vop (generic-eql/fixnum fast-eql/fixnum)
566   (:arg-types * tagged-num)
567   (:variant-cost 7))
568
569 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
570   (:args (x :scs (any-reg descriptor-reg)))
571   (:arg-types tagged-num (:constant (signed-byte 9)))
572   (:info target not-p y)
573   (:translate eql)
574   (:generator 2
575     (inst bci := not-p (fixnumize y) x target)))
576 ;;;
577 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
578   (:arg-types * (:constant (signed-byte 9)))
579   (:variant-cost 6))
580
581 \f
582 ;;;; modular functions
583 (define-modular-fun +-mod32 (x y) + :unsigned 32)
584 (define-vop (fast-+-mod32/unsigned=>unsigned fast-+/unsigned=>unsigned)
585   (:translate +-mod32))
586 (define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned)
587   (:translate +-mod32))
588 (define-modular-fun --mod32 (x y) - :unsigned 32)
589 (define-vop (fast---mod32/unsigned=>unsigned fast--/unsigned=>unsigned)
590   (:translate --mod32))
591 (define-vop (fast---mod32-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
592   (:translate --mod32))
593
594 (define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
595              fast-ash-c/unsigned=>unsigned)
596   (:translate ash-left-mod32))
597 (define-vop (fast-ash-left-mod32/unsigned=>unsigned
598              ;; FIXME: when FAST-ASH-LEFT/UNSIGNED=>UNSIGNED is
599              ;; implemented, use it here.  -- CSR, 2004-08-16
600              fast-ash/unsigned=>unsigned))
601 (deftransform ash-left-mod32 ((integer count)
602                               ((unsigned-byte 32) (unsigned-byte 5)))
603   (when (sb!c::constant-lvar-p count)
604     (sb!c::give-up-ir1-transform))
605   '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
606
607 (define-modular-fun lognot-mod32 (x) lognot :unsigned 32)
608 (define-vop (lognot-mod32/unsigned=>unsigned)
609   (:translate lognot-mod32)
610   (:args (x :scs (unsigned-reg)))
611   (:arg-types unsigned-num)
612   (:results (res :scs (unsigned-reg)))
613   (:result-types unsigned-num)
614   (:policy :fast-safe)
615   (:generator 1
616     (inst uaddcm zero-tn x res)))
617
618 (macrolet
619     ((define-modular-backend (fun)
620        (let ((mfun-name (symbolicate fun '-mod32))
621              ;; FIXME: if anyone cares, add constant-arg vops.  --
622              ;; CSR, 2003-09-16
623              (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
624              (vop (symbolicate 'fast- fun '/unsigned=>unsigned)))
625          `(progn
626             (define-modular-fun ,mfun-name (x y) ,fun :unsigned 32)
627             (define-vop (,modvop ,vop)
628               (:translate ,mfun-name))))))
629   (define-modular-backend logxor)
630   (define-modular-backend logandc1)
631   (define-modular-backend logandc2))
632
633 (define-source-transform logeqv (&rest args)
634   (if (oddp (length args))
635       `(logxor ,@args)
636       `(lognot (logxor ,@args))))
637 (define-source-transform logorc1 (x y)
638   `(logior (lognot ,x) ,y))
639 (define-source-transform logorc2 (x y)
640   `(logior ,x (lognot ,y)))
641 (define-source-transform lognand (x y)
642   `(lognot (logand ,x ,y)))
643 (define-source-transform lognor (x y)
644   `(lognot (logior ,x y)))
645
646 (define-vop (shift-towards-someplace)
647   (:policy :fast-safe)
648   (:args (num :scs (unsigned-reg))
649          (amount :scs (signed-reg)))
650   (:arg-types unsigned-num tagged-num)
651   (:results (r :scs (unsigned-reg)))
652   (:result-types unsigned-num))
653
654 (define-vop (shift-towards-start shift-towards-someplace)
655   (:translate shift-towards-start)
656   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
657   (:note "SHIFT-TOWARDS-START")
658   (:generator 1
659     (inst subi 31 amount temp)
660     (inst mtctl temp :sar)
661     (inst zdep num :variable 32 r)))
662
663 (define-vop (shift-towards-end shift-towards-someplace)
664   (:translate shift-towards-end)
665   (:note "SHIFT-TOWARDS-END")
666   (:generator 1
667     (inst mtctl amount :sar)
668     (inst shd zero-tn num :variable r)))
669
670
671 \f
672 ;;;; Bignum stuff.
673
674 (define-vop (bignum-length get-header-data)
675   (:translate sb!bignum:%bignum-length)
676   (:policy :fast-safe))
677
678 (define-vop (bignum-set-length set-header-data)
679   (:translate sb!bignum:%bignum-set-length)
680   (:policy :fast-safe))
681
682 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
683   (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
684
685 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
686   (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
687
688 (define-vop (digit-0-or-plus)
689   (:translate sb!bignum:%digit-0-or-plusp)
690   (:policy :fast-safe)
691   (:args (digit :scs (unsigned-reg)))
692   (:arg-types unsigned-num)
693   (:conditional)
694   (:info target not-p)
695   (:effects)
696   (:affected)
697   (:generator 1
698     (inst bc :>= not-p digit zero-tn target)))
699
700 (define-vop (add-w/carry)
701   (:translate sb!bignum:%add-with-carry)
702   (:policy :fast-safe)
703   (:args (a :scs (unsigned-reg))
704          (b :scs (unsigned-reg))
705          (c :scs (unsigned-reg)))
706   (:arg-types unsigned-num unsigned-num positive-fixnum)
707   (:results (result :scs (unsigned-reg))
708             (carry :scs (unsigned-reg)))
709   (:result-types unsigned-num positive-fixnum)
710   (:generator 3
711     (inst addi -1 c zero-tn)
712     (inst addc a b result)
713     (inst addc zero-tn zero-tn carry)))
714
715 (define-vop (sub-w/borrow)
716   (:translate sb!bignum:%subtract-with-borrow)
717   (:policy :fast-safe)
718   (:args (a :scs (unsigned-reg))
719          (b :scs (unsigned-reg))
720          (c :scs (unsigned-reg)))
721   (:arg-types unsigned-num unsigned-num positive-fixnum)
722   (:results (result :scs (unsigned-reg))
723             (borrow :scs (unsigned-reg)))
724   (:result-types unsigned-num positive-fixnum)
725   (:generator 4
726     (inst addi -1 c zero-tn)
727     (inst subb a b result)
728     (inst addc zero-tn zero-tn borrow)))
729
730 (define-vop (bignum-mult)
731   (:translate sb!bignum:%multiply)
732   (:policy :fast-safe)
733   (:args (x-arg :scs (unsigned-reg) :target x)
734          (y-arg :scs (unsigned-reg) :target y))
735   (:arg-types unsigned-num unsigned-num)
736   (:temporary (:scs (signed-reg) :from (:argument 0)) x)
737   (:temporary (:scs (signed-reg) :from (:argument 1)) y)
738   (:temporary (:scs (signed-reg)) tmp)
739   (:results (hi :scs (unsigned-reg))
740             (lo :scs (unsigned-reg)))
741   (:result-types unsigned-num unsigned-num)
742   (:generator 3
743     ;; Make sure X is less then Y.
744     (inst comclr x-arg y-arg tmp :<<)
745     (inst xor x-arg y-arg tmp)
746     (inst xor x-arg tmp x)
747     (inst xor y-arg tmp y)
748
749     ;; Blow out of here if the result is zero.
750     (inst li 0 hi)
751     (inst comb := x zero-tn done)
752     (inst li 0 lo)
753     (inst li 0 tmp)
754
755     LOOP
756     (inst comb :ev x zero-tn next-bit)
757     (inst srl x 1 x)
758     (inst add lo y lo)
759     (inst addc hi tmp hi)
760     NEXT-BIT
761     (inst add y y y)
762     (inst comb :<> x zero-tn loop)
763     (inst addc tmp tmp tmp)
764
765     DONE))
766
767 (define-source-transform sb!bignum:%multiply-and-add (x y carry &optional (extra 0))
768   #+nil ;; This would be greate if it worked, but it doesn't.
769   (if (eql extra 0)
770       `(multiple-value-call #'sb!bignum:%dual-word-add
771          (sb!bignum:%multiply ,x ,y)
772          (values ,carry))
773       `(multiple-value-call #'sb!bignum:%dual-word-add
774          (multiple-value-call #'sb!bignum:%dual-word-add
775            (sb!bignum:%multiply ,x ,y)
776            (values ,carry))
777          (values ,extra)))
778   (with-unique-names (hi lo)
779     (if (eql extra 0)
780         `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
781            (sb!bignum::%dual-word-add ,hi ,lo ,carry))
782         `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
783            (multiple-value-bind
784                (,hi ,lo)
785                (sb!bignum::%dual-word-add ,hi ,lo ,carry)
786              (sb!bignum::%dual-word-add ,hi ,lo ,extra))))))
787
788 (defknown sb!bignum::%dual-word-add
789           (sb!bignum:bignum-element-type sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
790   (values sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
791   (flushable movable))
792
793 (define-vop (dual-word-add)
794   (:policy :fast-safe)
795   (:translate sb!bignum::%dual-word-add)
796   (:args (hi :scs (unsigned-reg) :to (:result 1))
797          (lo :scs (unsigned-reg))
798          (extra :scs (unsigned-reg)))
799   (:arg-types unsigned-num unsigned-num unsigned-num)
800   (:results (hi-res :scs (unsigned-reg) :from (:result 1))
801             (lo-res :scs (unsigned-reg) :from (:result 0)))
802   (:result-types unsigned-num unsigned-num)
803   (:affected)
804   (:effects)
805   (:generator 3
806     (inst add lo extra lo-res)
807     (inst addc hi zero-tn hi-res)))
808
809 (define-vop (bignum-lognot)
810   (:translate sb!bignum:%lognot)
811   (:policy :fast-safe)
812   (:args (x :scs (unsigned-reg)))
813   (:arg-types unsigned-num)
814   (:results (r :scs (unsigned-reg)))
815   (:result-types unsigned-num)
816   (:generator 1
817     (inst uaddcm zero-tn x r)))
818
819 (define-vop (fixnum-to-digit)
820   (:translate sb!bignum:%fixnum-to-digit)
821   (:policy :fast-safe)
822   (:args (fixnum :scs (signed-reg)))
823   (:arg-types tagged-num)
824   (:results (digit :scs (unsigned-reg)))
825   (:result-types unsigned-num)
826   (:generator 1
827     (move fixnum digit)))
828
829 (define-vop (bignum-floor)
830   (:translate sb!bignum:%floor)
831   (:policy :fast-safe)
832   (:args (hi :scs (unsigned-reg) :to (:argument 1))
833          (lo :scs (unsigned-reg) :to (:argument 0))
834          (divisor :scs (unsigned-reg)))
835   (:arg-types unsigned-num unsigned-num unsigned-num)
836   (:temporary (:scs (unsigned-reg) :to (:argument 1)) temp)
837   (:results (quo :scs (unsigned-reg) :from (:argument 0))
838             (rem :scs (unsigned-reg) :from (:argument 1)))
839   (:result-types unsigned-num unsigned-num)
840   (:generator 65
841     (inst sub zero-tn divisor temp)
842     (inst ds zero-tn temp zero-tn)
843     (inst add lo lo quo)
844     (inst ds hi divisor rem)
845     (inst addc quo quo quo)
846     (dotimes (i 31)
847       (inst ds rem divisor rem)
848       (inst addc quo quo quo))
849     (inst comclr rem zero-tn zero-tn :>=)
850     (inst add divisor rem rem)))
851
852 (define-vop (signify-digit)
853   (:translate sb!bignum:%fixnum-digit-with-correct-sign)
854   (:policy :fast-safe)
855   (:args (digit :scs (unsigned-reg) :target res))
856   (:arg-types unsigned-num)
857   (:results (res :scs (signed-reg)))
858   (:result-types signed-num)
859   (:generator 1
860     (move digit res)))
861
862 (define-vop (digit-lshr)
863   (:translate sb!bignum:%digit-logical-shift-right)
864   (:policy :fast-safe)
865   (:args (digit :scs (unsigned-reg))
866          (count :scs (unsigned-reg)))
867   (:arg-types unsigned-num positive-fixnum)
868   (:results (result :scs (unsigned-reg)))
869   (:result-types unsigned-num)
870   (:generator 2
871     (inst mtctl count :sar)
872     (inst shd zero-tn digit :variable result)))
873
874 (define-vop (digit-ashr digit-lshr)
875   (:translate sb!bignum:%ashr)
876   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
877   (:generator 1
878     (inst extrs digit 0 1 temp)
879     (inst mtctl count :sar)
880     (inst shd temp digit :variable result)))
881
882 (define-vop (digit-ashl digit-ashr)
883   (:translate sb!bignum:%ashl)
884   (:generator 1
885     (inst subi 31 count temp)
886     (inst mtctl temp :sar)
887     (inst zdep digit :variable 32 result)))
888
889 \f
890 ;;;; Static functions.
891
892 (define-static-fun two-arg-gcd (x y) :translate gcd)
893 (define-static-fun two-arg-lcm (x y) :translate lcm)
894
895 (define-static-fun two-arg-* (x y) :translate *)
896 (define-static-fun two-arg-/ (x y) :translate /)
897
898 (define-static-fun %negate (x) :translate %negate)
899
900 (define-static-fun two-arg-and (x y) :translate logand)
901 (define-static-fun two-arg-ior (x y) :translate logior)
902 (define-static-fun two-arg-xor (x y) :translate logxor)