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