1;;;; the VM definition arithmetic VOPs for the Alpha
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 (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 64) 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 subq zero-tn x res)))
36
37(define-vop (fast-negate/signed signed-unop)
38  (:translate %negate)
39  (:generator 2
40    (inst subq zero-tn x res)))
41
42(define-vop (fast-lognot/fixnum fixnum-unop)
43  (:translate lognot)
44  (:generator 1
45    (inst eqv x fixnum-tag-mask res)))
46
47(define-vop (fast-lognot/signed signed-unop)
48  (:translate lognot)
49  (:generator 2
50    (inst not x res)))
51
52;;;; binary fixnum operations
53
54;;; Assume that any constant operand is the second arg...
55
56(define-vop (fast-fixnum-binop)
57  (:args (x :target r :scs (any-reg))
58         (y :target r :scs (any-reg)))
59  (:arg-types tagged-num tagged-num)
60  (:results (r :scs (any-reg)))
61  (:result-types tagged-num)
62  (:note "inline fixnum arithmetic")
63  (:effects)
64  (:affected)
65  (:policy :fast-safe))
66
67(define-vop (fast-unsigned-binop)
68  (:args (x :target r :scs (unsigned-reg))
69         (y :target r :scs (unsigned-reg)))
70  (:arg-types unsigned-num unsigned-num)
71  (:results (r :scs (unsigned-reg)))
72  (:result-types unsigned-num)
73  (:note "inline (unsigned-byte 64) arithmetic")
74  (:effects)
75  (:affected)
76  (:policy :fast-safe))
77
78(define-vop (fast-signed-binop)
79  (:args (x :target r :scs (signed-reg))
80         (y :target r :scs (signed-reg)))
81  (:arg-types signed-num signed-num)
82  (:results (r :scs (signed-reg)))
83  (:result-types signed-num)
84  (:note "inline (signed-byte 64) arithmetic")
85  (:effects)
86  (:affected)
87  (:policy :fast-safe))
88
89(define-vop (fast-fixnum-c-binop fast-fixnum-binop)
90  (:args (x :target r :scs (any-reg)))
91  (:info y)
92  (:arg-types tagged-num (:constant integer)))
93
94(define-vop (fast-signed-c-binop fast-signed-binop)
95  (:args (x :target r :scs (signed-reg)))
96  (:info y)
97  (:arg-types signed-num (:constant integer)))
98
99(define-vop (fast-unsigned-c-binop fast-unsigned-binop)
100  (:args (x :target r :scs (unsigned-reg)))
101  (:info y)
102  (:arg-types unsigned-num (:constant integer)))
103
104(defmacro define-binop (translate cost untagged-cost op
105                        tagged-type untagged-type
106                        &optional arg-swap restore-fixnum-mask)
107  `(progn
108     (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
109                  fast-fixnum-binop)
110       ,@(when restore-fixnum-mask
111           `((:temporary (:sc non-descriptor-reg) temp)))
112       (:args (x ,@(unless restore-fixnum-mask `(:target r)) :scs (any-reg))
113              (y ,@(unless restore-fixnum-mask `(:target r)) :scs (any-reg)))
114       (:translate ,translate)
115       (:generator ,(1+ cost)
116         ,(if arg-swap
117              `(inst ,op y x ,(if restore-fixnum-mask 'temp 'r))
118              `(inst ,op x y ,(if restore-fixnum-mask 'temp 'r)))
119         ,@(when restore-fixnum-mask
120             `((inst bic temp #.(ash lowtag-mask -1) r)))))
121     (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
122                  fast-signed-binop)
123       (:args (x :target r :scs (signed-reg))
124              (y :target r :scs (signed-reg)))
125       (:translate ,translate)
126       (:generator ,(1+ untagged-cost)
127         ,(if arg-swap
128              `(inst ,op y x r)
129              `(inst ,op x y r))))
130     (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
131                  fast-unsigned-binop)
132       (:args (x :target r :scs (unsigned-reg))
133              (y :target r :scs (unsigned-reg)))
134       (:translate ,translate)
135       (:generator ,(1+ untagged-cost)
136         ,(if arg-swap
137              `(inst ,op y x r)
138              `(inst ,op x y r))))
139     ,@(when (and tagged-type (not arg-swap))
140         `((define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
141                        fast-fixnum-c-binop)
142             (:args (x ,@(unless restore-fixnum-mask `(:target r))
143                       :scs (any-reg)))
144             (:arg-types tagged-num (:constant ,tagged-type))
145             ,@(when restore-fixnum-mask
146                 `((:temporary (:sc non-descriptor-reg) temp)))
147             (:translate ,translate)
148             (:generator ,cost
149                (inst ,op x (fixnumize y) ,(if restore-fixnum-mask 'temp 'r))
150                ,@(when restore-fixnum-mask
151                    `((inst bic temp #.(ash lowtag-mask -1) r)))))))
152     ,@(when (and untagged-type (not arg-swap))
153         `((define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
154                        fast-signed-c-binop)
155             (:arg-types signed-num (:constant ,untagged-type))
156             (:translate ,translate)
157             (:generator ,untagged-cost
158                (inst ,op x y r)))
159           (define-vop (,(symbolicate "FAST-" translate
160                                      "-C/UNSIGNED=>UNSIGNED")
161                        fast-unsigned-c-binop)
162             (:arg-types unsigned-num (:constant ,untagged-type))
163             (:translate ,translate)
164             (:generator ,untagged-cost
165                (inst ,op x y r)))))))
166
167(define-binop + 1 5 addq (unsigned-byte 6) (unsigned-byte 8))
168(define-binop - 1 5 subq (unsigned-byte 6) (unsigned-byte 8))
169(define-binop logand 1 3 and (unsigned-byte 6) (unsigned-byte 8))
170(define-binop logandc1 1 3 bic (unsigned-byte 6) (unsigned-byte 8) t)
171(define-binop logandc2 1 3 bic (unsigned-byte 6) (unsigned-byte 8))
172(define-binop logior 1 3 bis (unsigned-byte 6) (unsigned-byte 8))
173(define-binop logorc1 1 3 ornot (unsigned-byte 6) (unsigned-byte 8) t t)
174(define-binop logorc2 1 3 ornot (unsigned-byte 6) (unsigned-byte 8) nil t)
175(define-binop logxor 1 3 xor (unsigned-byte 6) (unsigned-byte 8))
176(define-binop logeqv 1 3 eqv (unsigned-byte 6) (unsigned-byte 8) nil t)
177
178;;; special cases for LOGAND where we can use a mask operation
179(define-vop (fast-logand-c-mask/unsigned=>unsigned fast-unsigned-c-binop)
180  (:translate logand)
181  (:arg-types unsigned-num
182              (:constant (or (integer #xffffffff #xffffffff)
183                             (integer #xffffffff00000000 #xffffffff00000000))))
184  (:generator 1
185    (ecase y
186      (#xffffffff (inst mskll x 4 r))
187      (#xffffffff00000000 (inst mskll x 0 r)))))
188
189;;;; shifting
190
191(define-vop (fast-ash/unsigned=>unsigned)
192  (:note "inline ASH")
193  (:args (number :scs (unsigned-reg) :to :save)
194         (amount :scs (signed-reg)))
195  (:arg-types unsigned-num signed-num)
196  (:results (result :scs (unsigned-reg)))
197  (:result-types unsigned-num)
198  (:translate ash)
199  (:policy :fast-safe)
200  (:temporary (:sc non-descriptor-reg) ndesc)
201  (:temporary (:sc non-descriptor-reg) temp)
202  (:generator 3
203    (inst bge amount positive)
204    (inst subq zero-tn amount ndesc)
205    (inst cmplt ndesc 64 temp)
206    (inst srl number ndesc result)
207    ;; FIXME: this looks like a candidate for a conditional move --
208    ;; CSR, 2003-09-10
209    (inst bne temp done)
210    (move zero-tn result)
211    (inst br zero-tn done)
212
213    POSITIVE
214    (inst sll number amount result)
215
216    DONE))
217
218(define-vop (fast-ash/signed=>signed)
219  (:note "inline ASH")
220  (:args (number :scs (signed-reg) :to :save)
221         (amount :scs (signed-reg)))
222  (:arg-types signed-num signed-num)
223  (:results (result :scs (signed-reg)))
224  (:result-types signed-num)
225  (:translate ash)
226  (:policy :fast-safe)
227  (:temporary (:sc non-descriptor-reg) ndesc)
228  (:temporary (:sc non-descriptor-reg) temp)
229  (:generator 3
230    (inst bge amount positive)
231    (inst subq zero-tn amount ndesc)
232    (inst cmplt ndesc 63 temp)
233    (inst sra number ndesc result)
234    (inst bne temp done)
235    (inst sra number 63 result)
236    (inst br zero-tn done)
237
238    POSITIVE
239    (inst sll number amount result)
240
241    DONE))
242
243(define-vop (fast-ash-c/signed=>signed)
244  (:policy :fast-safe)
245  (:translate ash)
246  (:note nil)
247  (:args (number :scs (signed-reg)))
248  (:info count)
249  (:arg-types signed-num (:constant integer))
250  (:results (result :scs (signed-reg)))
251  (:result-types signed-num)
252  (:generator 1
253    (cond
254      ((< count 0) (inst sra number (min 63 (- count)) result))
255      ((> count 0) (inst sll number (min 63 count) result))
256      (t (bug "identity ASH not transformed away")))))
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
269      ((< count -63) (move zero-tn result))
270      ((< count 0) (inst sra number (- count) result))
271      ((> count 0) (inst sll number (min 63 count) result))
272      (t (bug "identity ASH not transformed away")))))
273
274(macrolet ((def (name sc-type type result-type cost)
275             `(define-vop (,name)
276                (:note "inline ASH")
277                (:translate ash)
278                (:args (number :scs (,sc-type))
279                       (amount :scs (signed-reg unsigned-reg immediate)))
280                (:arg-types ,type positive-fixnum)
281                (:results (result :scs (,result-type)))
282                (:result-types ,type)
283                (:policy :fast-safe)
284                (:generator ,cost
285                   (sc-case amount
286                     ((signed-reg unsigned-reg)
287                      (inst sll number amount result))
288                     (immediate
289                      (let ((amount (tn-value amount)))
290                        (aver (> amount 0))
291                        (inst sll number amount result))))))))
292  (def fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2)
293  (def fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3)
294  (def fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3))
295
296(define-vop (signed-byte-64-len)
297  (:translate integer-length)
298  (:note "inline (signed-byte 64) integer-length")
299  (:policy :fast-safe)
300  (:args (arg :scs (signed-reg) :to (:argument 1)))
301  (:arg-types signed-num)
302  (:results (res :scs (any-reg)))
303  (:result-types positive-fixnum)
304  (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
305  (:generator 30
306    (inst not arg shift)
307    (inst cmovge arg arg shift)
308    (inst subq zero-tn (fixnumize 1) res)
309    (inst sll shift 1 shift)
310    LOOP
311    (inst addq res (fixnumize 1) res)
312    (inst srl shift 1 shift)
313    (inst bne shift loop)))
314
315(define-vop (unsigned-byte-64-count)
316  (:translate logcount)
317  (:note "inline (unsigned-byte 64) logcount")
318  (:policy :fast-safe)
319  (:args (arg :scs (unsigned-reg)))
320  (:arg-types unsigned-num)
321  (:results (res :scs (unsigned-reg)))
322  (:result-types positive-fixnum)
323  (:guard (member :cix *backend-subfeatures*))
324  (:generator 1
325    (inst ctpop zero-tn arg res)))
326
327(define-vop (unsigned-byte-64-count)
328  (:translate logcount)
329  (:note "inline (unsigned-byte 64) logcount")
330  (:policy :fast-safe)
331  (:args (arg :scs (unsigned-reg) :target num))
332  (:arg-types unsigned-num)
333  (:results (res :scs (unsigned-reg)))
334  (:result-types positive-fixnum)
335  (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0)
336                    :target res) num)
337  (:temporary (:scs (non-descriptor-reg)) mask temp)
338  (:generator 60
339    ;; FIXME: now this looks expensive, what with these 64bit loads.
340    ;; Maybe a loop and count would be faster?  -- CSR, 2003-09-10
341    (inst li #x5555555555555555 mask)
342    (inst srl arg 1 temp)
343    (inst and arg mask num)
344    (inst and temp mask temp)
345    (inst addq num temp num)
346    (inst li #x3333333333333333 mask)
347    (inst srl num 2 temp)
348    (inst and num mask num)
349    (inst and temp mask temp)
350    (inst addq num temp num)
351    (inst li #x0f0f0f0f0f0f0f0f mask)
352    (inst srl num 4 temp)
353    (inst and num mask num)
354    (inst and temp mask temp)
355    (inst addq num temp num)
356    (inst li #x00ff00ff00ff00ff mask)
357    (inst srl num 8 temp)
358    (inst and num mask num)
359    (inst and temp mask temp)
360    (inst addq num temp num)
361    (inst li #x0000ffff0000ffff mask)
362    (inst srl num 16 temp)
363    (inst and num mask num)
364    (inst and temp mask temp)
365    (inst addq num temp num)
366    (inst li #x00000000ffffffff mask)
367    (inst srl num 32 temp)
368    (inst and num mask num)
369    (inst and temp mask temp)
370    (inst addq num temp res)))
371
372;;;; multiplying
373
374(define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
375  (:temporary (:scs (non-descriptor-reg)) temp)
376  (:translate *)
377  (:generator 4
378    (inst sra y n-fixnum-tag-bits temp)
379    (inst mulq x temp r)))
380
381(define-vop (fast-*/signed=>signed fast-signed-binop)
382  (:translate *)
383  (:generator 3
384    (inst mulq x y r)))
385
386(define-vop (fast-*/unsigned=>unsigned fast-unsigned-binop)
387  (:translate *)
388  (:generator 3
389    (inst mulq x y r)))
390
391;;;; Modular functions:
392(define-modular-fun lognot-mod64 (x) lognot :untagged nil 64)
393(define-vop (lognot-mod64/unsigned=>unsigned)
394  (:translate lognot-mod64)
395  (:args (x :scs (unsigned-reg)))
396  (:arg-types unsigned-num)
397  (:results (res :scs (unsigned-reg)))
398  (:result-types unsigned-num)
399  (:policy :fast-safe)
400  (:generator 1
401    (inst not x res)))
402
403(define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
404             fast-ash-c/unsigned=>unsigned)
405  (:translate ash-left-mod64))
406(define-vop (fast-ash-left-mod64/unsigned=>unsigned
407             fast-ash-left/unsigned=>unsigned))
408(deftransform ash-left-mod64 ((integer count)
409                              ((unsigned-byte 64) (unsigned-byte 6)))
410  (when (sb!c::constant-lvar-p count)
411    (sb!c::give-up-ir1-transform))
412  '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
413
414(macrolet
415    ((define-modular-backend (fun &optional constantp)
416       (let ((mfun-name (symbolicate fun '-mod64))
417             (modvop (symbolicate 'fast- fun '-mod64/unsigned=>unsigned))
418             (modcvop (symbolicate 'fast- fun '-mod64-c/unsigned=>unsigned))
419             (vop (symbolicate 'fast- fun '/unsigned=>unsigned))
420             (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
421         `(progn
422            (define-modular-fun ,mfun-name (x y) ,fun :untagged nil 64)
423            (define-vop (,modvop ,vop)
424              (:translate ,mfun-name))
425            ,@(when constantp
426                `((define-vop (,modcvop ,cvop)
427                    (:translate ,mfun-name))))))))
428  (define-modular-backend + t)
429  (define-modular-backend - t)
430  (define-modular-backend logeqv t)
431  (define-modular-backend logandc1)
432  (define-modular-backend logandc2 t)
433  (define-modular-backend logorc1)
434  (define-modular-backend logorc2 t))
435
436(define-source-transform lognand (x y)
437  `(lognot (logand ,x ,y)))
438(define-source-transform lognor (x y)
439  `(lognot (logior ,x ,y)))
440
441;;;; binary conditional VOPs
442
443(define-vop (fast-conditional)
444  (:conditional)
445  (:info target not-p)
446  (:effects)
447  (:affected)
448  (:temporary (:scs (non-descriptor-reg)) temp)
449  (:policy :fast-safe))
450
451(define-vop (fast-conditional/fixnum fast-conditional)
452  (:args (x :scs (any-reg))
453         (y :scs (any-reg)))
454  (:arg-types tagged-num tagged-num)
455  (:note "inline fixnum comparison"))
456
457(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
458  (:args (x :scs (any-reg)))
459  (:arg-types tagged-num (:constant (unsigned-byte-with-a-bite-out 6 4)))
460  (:info target not-p y))
461
462(define-vop (fast-conditional/signed fast-conditional)
463  (:args (x :scs (signed-reg))
464         (y :scs (signed-reg)))
465  (:arg-types signed-num signed-num)
466  (:note "inline (signed-byte 64) comparison"))
467
468(define-vop (fast-conditional-c/signed fast-conditional/signed)
469  (:args (x :scs (signed-reg)))
470  (:arg-types signed-num (:constant (unsigned-byte-with-a-bite-out 8 1)))
471  (:info target not-p y))
472
473(define-vop (fast-conditional/unsigned fast-conditional)
474  (:args (x :scs (unsigned-reg))
475         (y :scs (unsigned-reg)))
476  (:arg-types unsigned-num unsigned-num)
477  (:note "inline (unsigned-byte 64) comparison"))
478
479(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
480  (:args (x :scs (unsigned-reg)))
481  (:arg-types unsigned-num (:constant (unsigned-byte-with-a-bite-out 8 1)))
482  (:info target not-p y))
483
484
485(defmacro define-conditional-vop (translate &rest generator)
486  `(progn
487     ,@(mapcar (lambda (suffix cost signed)
488                 (unless (and (member suffix '(/fixnum -c/fixnum))
489                              (eq translate 'eql))
490                   `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
491                                                  translate suffix))
492                                 ,(intern
493                                   (format nil "~:@(FAST-CONDITIONAL~A~)"
494                                           suffix)))
495                      (:translate ,translate)
496                      (:generator ,cost
497                                  (let* ((signed ,signed)
498                                         (-c/fixnum ,(eq suffix '-c/fixnum))
499                                         (y (if -c/fixnum (fixnumize y) y)))
500                                    ,@generator)))))
501               '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
502               '(3 2 5 4 5 4)
503               '(t t t t nil nil))))
504
505(define-conditional-vop <
506  (cond ((and signed (eql y 0))
507         (if not-p
508             (inst bge x target)
509             (inst blt x target)))
510        (t
511         (if signed
512             (inst cmplt x y temp)
513             (inst cmpult x y temp))
514         (if not-p
515             (inst beq temp target)
516             (inst bne temp target)))))
517
518(define-conditional-vop >
519  (cond ((and signed (eql y 0))
520         (if not-p
521             (inst ble x target)
522             (inst bgt x target)))
523        ((integerp y)
524         (let ((y (+ y (if -c/fixnum (fixnumize 1) 1))))
525           (if signed
526               (inst cmplt x y temp)
527               (inst cmpult x y temp))
528           (if not-p
529               (inst bne temp target)
530               (inst beq temp target))))
531        (t
532         (if signed
533             (inst cmplt y x temp)
534             (inst cmpult y x temp))
535         (if not-p
536             (inst beq temp target)
537             (inst bne temp target)))))
538
539;;; EQL/FIXNUM is funny because the first arg can be of any type, not
540;;; just a known fixnum.
541
542(define-conditional-vop eql
543  (declare (ignore signed))
544  (when (integerp y)
545    (inst li y temp)
546    (setf y temp))
547  (inst cmpeq x y temp)
548  (if not-p
549      (inst beq temp target)
550      (inst bne temp target)))
551
552;;; These versions specify a fixnum restriction on their first arg. We
553;;; have also generic-eql/fixnum VOPs which are the same, but have no
554;;; restriction on the first arg and a higher cost. The reason for
555;;; doing this is to prevent fixnum specific operations from being
556;;; used on word integers, spuriously consing the argument.
557(define-vop (fast-eql/fixnum fast-conditional)
558  (:args (x :scs (any-reg))
559         (y :scs (any-reg)))
560  (:arg-types tagged-num tagged-num)
561  (:note "inline fixnum comparison")
562  (:translate eql)
563  (:generator 3
564    (cond ((equal y zero-tn)
565           (if not-p
566               (inst bne x target)
567               (inst beq x target)))
568          (t
569           (inst cmpeq x y temp)
570           (if not-p
571               (inst beq temp target)
572               (inst bne temp target))))))
573
574;;;
575(define-vop (generic-eql/fixnum fast-eql/fixnum)
576  (:args (x :scs (any-reg descriptor-reg))
577         (y :scs (any-reg)))
578  (:arg-types * tagged-num)
579  (:variant-cost 7))
580
581(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
582  (:args (x :scs (any-reg)))
583  (:arg-types tagged-num (:constant (signed-byte 6)))
584  (:temporary (:scs (non-descriptor-reg)) temp)
585  (:info target not-p y)
586  (:translate eql)
587  (:generator 2
588    (let ((y (cond ((eql y 0) zero-tn)
589                   (t
590                    (inst li (fixnumize y) temp)
591                    temp))))
592      (inst cmpeq x y temp)
593      (if not-p
594          (inst beq temp target)
595          (inst bne temp target)))))
596;;;
597(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
598  (:args (x :scs (any-reg descriptor-reg)))
599  (:arg-types * (:constant (signed-byte 6)))
600  (:variant-cost 6))
601
602
603;;;; 32-bit logical operations
604
605(define-vop (shift-towards-someplace)
606  (:policy :fast-safe)
607  (:args (num :scs (unsigned-reg))
608         (amount :scs (signed-reg)))
609  (:arg-types unsigned-num tagged-num)
610  (:results (r :scs (unsigned-reg)))
611  (:result-types unsigned-num))
612
613(define-vop (shift-towards-start shift-towards-someplace)
614  (:translate shift-towards-start)
615  (:note "SHIFT-TOWARDS-START")
616  (:temporary (:sc non-descriptor-reg) temp)
617  (:generator 1
618    (inst and amount #x1f temp)
619    (inst srl num temp r)))
620
621(define-vop (shift-towards-end shift-towards-someplace)
622  (:translate shift-towards-end)
623  (:note "SHIFT-TOWARDS-END")
624  (:temporary (:sc non-descriptor-reg) temp)
625  (:generator 1
626    (inst and amount #x1f temp)
627    (inst sll num temp r)))
628
629;;;; bignum stuff
630
631(define-vop (bignum-length get-header-data)
632  (:translate sb!bignum:%bignum-length)
633  (:policy :fast-safe))
634
635(define-vop (bignum-set-length set-header-data)
636  (:translate sb!bignum:%bignum-set-length)
637  (:policy :fast-safe))
638
639(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
640  (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
641
642(define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
643  (unsigned-reg) unsigned-num sb!bignum:%bignum-set #!+gengc nil)
644
645(define-vop (digit-0-or-plus)
646  (:translate sb!bignum:%digit-0-or-plusp)
647  (:policy :fast-safe)
648  (:args (digit :scs (unsigned-reg)))
649  (:arg-types unsigned-num)
650  (:temporary (:sc non-descriptor-reg) temp)
651  (:conditional)
652  (:info target not-p)
653  (:generator 2
654    (inst sll digit 32 temp)
655    (if not-p
656        (inst blt temp target)
657        (inst bge temp target))))
658
659(define-vop (add-w/carry)
660  (:translate sb!bignum:%add-with-carry)
661  (:policy :fast-safe)
662  (:args (a :scs (unsigned-reg))
663         (b :scs (unsigned-reg))
664         (c :scs (unsigned-reg)))
665  (:arg-types unsigned-num unsigned-num positive-fixnum)
666  (:results (result :scs (unsigned-reg) :from :load)
667            (carry :scs (unsigned-reg) :from :eval))
668  (:result-types unsigned-num positive-fixnum)
669  (:generator 5
670    (inst addq a b result)
671    (inst addq result c result)
672    (inst sra result 32 carry)
673    (inst mskll result 4 result)))
674
675(define-vop (sub-w/borrow)
676  (:translate sb!bignum:%subtract-with-borrow)
677  (:policy :fast-safe)
678  (:args (a :scs (unsigned-reg))
679         (b :scs (unsigned-reg))
680         (c :scs (unsigned-reg)))
681  (:arg-types unsigned-num unsigned-num positive-fixnum)
682  (:results (result :scs (unsigned-reg) :from :load)
683            (borrow :scs (unsigned-reg) :from :eval))
684  (:result-types unsigned-num positive-fixnum)
685  (:generator 4
686    (inst xor c 1 result)
687    (inst subq a result result)
688    (inst subq result b result)
689    (inst srl result 63 borrow)
690    (inst xor borrow 1 borrow)
691    (inst mskll result 4 result)))
692
693(define-vop (bignum-mult-and-add-3-arg)
694  (:translate sb!bignum:%multiply-and-add)
695  (:policy :fast-safe)
696  (:args (x :scs (unsigned-reg))
697         (y :scs (unsigned-reg))
698         (carry-in :scs (unsigned-reg) :to :save))
699  (:arg-types unsigned-num unsigned-num unsigned-num)
700  (:results (hi :scs (unsigned-reg))
701            (lo :scs (unsigned-reg)))
702  (:result-types unsigned-num unsigned-num)
703  (:generator 6
704    (inst mulq x y lo)
705    (inst addq lo carry-in lo)
706    (inst srl lo 32 hi)
707    (inst mskll lo 4 lo)))
708
709
710(define-vop (bignum-mult-and-add-4-arg)
711  (:translate sb!bignum:%multiply-and-add)
712  (:policy :fast-safe)
713  (:args (x :scs (unsigned-reg))
714         (y :scs (unsigned-reg))
715         (prev :scs (unsigned-reg))
716         (carry-in :scs (unsigned-reg) :to :save))
717  (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
718  (:results (hi :scs (unsigned-reg))
719            (lo :scs (unsigned-reg)))
720  (:result-types unsigned-num unsigned-num)
721  (:generator 9
722    (inst mulq x y lo)
723    (inst addq lo prev lo)
724    (inst addq lo carry-in lo)
725    (inst srl lo 32 hi)
726    (inst mskll lo 4 lo)))
727
728(define-vop (bignum-mult)
729  (:translate sb!bignum:%multiply)
730  (:policy :fast-safe)
731  (:args (x :scs (unsigned-reg))
732         (y :scs (unsigned-reg)))
733  (:arg-types unsigned-num unsigned-num)
734  (:results (hi :scs (unsigned-reg))
735            (lo :scs (unsigned-reg)))
736  (:result-types unsigned-num unsigned-num)
737  (:generator 3
738    (inst mulq x y lo)
739    (inst srl lo 32 hi)
740    (inst mskll lo 4 lo)))
741
742(define-vop (bignum-lognot)
743  (:translate sb!bignum:%lognot)
744  (:policy :fast-safe)
745  (:args (x :scs (unsigned-reg)))
746  (:arg-types unsigned-num)
747  (:results (r :scs (unsigned-reg)))
748  (:result-types unsigned-num)
749  (:generator 1
750    (inst not x r)
751    (inst mskll r 4 r)))
752
753(define-vop (fixnum-to-digit)
754  (:translate sb!bignum:%fixnum-to-digit)
755  (:policy :fast-safe)
756  (:args (fixnum :scs (any-reg)))
757  (:arg-types tagged-num)
758  (:results (digit :scs (unsigned-reg)))
759  (:result-types unsigned-num)
760  (:generator 1
761    (inst sra fixnum n-fixnum-tag-bits digit)))
762
763(define-vop (bignum-floor)
764  (:translate sb!bignum:%bigfloor)
765  (:policy :fast-safe)
766  (:args (num-high :scs (unsigned-reg))
767         (num-low :scs (unsigned-reg))
768         (denom-arg :scs (unsigned-reg) :target denom))
769  (:arg-types unsigned-num unsigned-num unsigned-num)
770  (:temporary (:scs (unsigned-reg) :from (:argument 2)) denom)
771  (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp)
772  (:results (quo :scs (unsigned-reg) :from (:eval 0))
773            (rem :scs (unsigned-reg) :from (:argument 0)))
774  (:result-types unsigned-num unsigned-num)
775  (:generator 325 ; number of inst assuming targeting works.
776    (inst sll num-high 32 rem)
777    (inst bis rem num-low rem)
778    (inst sll denom-arg 32 denom)
779    (inst cmpule denom rem quo)
780    (inst beq quo shift1)
781    (inst subq rem denom rem)
782    SHIFT1
783    (dotimes (i 32)
784      (let ((shift2 (gen-label)))
785        (inst srl denom 1 denom)
786        (inst cmpule denom rem temp)
787        (inst sll quo 1 quo)
788        (inst beq temp shift2)
789        (inst subq rem denom rem)
790        (inst bis quo 1 quo)
791        (emit-label shift2)))))
792
793(define-vop (signify-digit)
794  (:translate sb!bignum:%fixnum-digit-with-correct-sign)
795  (:policy :fast-safe)
796  (:args (digit :scs (unsigned-reg) :target res))
797  (:arg-types unsigned-num)
798  (:results (res :scs (any-reg signed-reg)))
799  (:result-types signed-num)
800  (:generator 2
801    (sc-case res
802      (any-reg
803       (inst sll digit 34 res)
804       (inst sra res 32 res))
805      (signed-reg
806       (inst sll digit 32 res)
807       (inst sra res 32 res)))))
808
809
810(define-vop (digit-ashr)
811  (:translate sb!bignum:%ashr)
812  (:policy :fast-safe)
813  (:args (digit :scs (unsigned-reg))
814         (count :scs (unsigned-reg)))
815  (:arg-types unsigned-num positive-fixnum)
816  (:results (result :scs (unsigned-reg) :from (:argument 0)))
817  (:result-types unsigned-num)
818  (:generator 1
819    (inst sll digit 32 result)
820    (inst sra result count result)
821    (inst srl result 32 result)))
822
823(define-vop (digit-lshr digit-ashr)
824  (:translate sb!bignum:%digit-logical-shift-right)
825  (:generator 1
826    (inst srl digit count result)))
827
828(define-vop (digit-ashl digit-ashr)
829  (:translate sb!bignum:%ashl)
830  (:generator 1
831    (inst sll digit count result)))
832
833;;;; static functions
834
835(define-static-fun two-arg-gcd (x y) :translate gcd)
836(define-static-fun two-arg-lcm (x y) :translate lcm)
837
838(define-static-fun two-arg-+ (x y) :translate +)
839(define-static-fun two-arg-- (x y) :translate -)
840(define-static-fun two-arg-* (x y) :translate *)
841(define-static-fun two-arg-/ (x y) :translate /)
842
843(define-static-fun two-arg-< (x y) :translate <)
844(define-static-fun two-arg-<= (x y) :translate <=)
845(define-static-fun two-arg-> (x y) :translate >)
846(define-static-fun two-arg->= (x y) :translate >=)
847(define-static-fun two-arg-= (x y) :translate =)
848(define-static-fun two-arg-/= (x y) :translate /=)
849
850(define-static-fun %negate (x) :translate %negate)
851
852(define-static-fun two-arg-and (x y) :translate logand)
853(define-static-fun two-arg-ior (x y) :translate logior)
854(define-static-fun two-arg-xor (x y) :translate logxor)
855(define-static-fun two-arg-eqv (x y) :translate logeqv)
856