1 ;;;; the VM definition of arithmetic VOPs for the x86-64
3 ;;;; This software is part of the SBCL system. See the README file for
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.
16 (define-vop (fast-safe-arith-op)
21 (define-vop (fixnum-unop fast-safe-arith-op)
22 (:args (x :scs (any-reg) :target res))
23 (:results (res :scs (any-reg)))
24 (:note "inline fixnum arithmetic")
25 (:arg-types tagged-num)
26 (:result-types tagged-num))
28 (define-vop (signed-unop fast-safe-arith-op)
29 (:args (x :scs (signed-reg) :target res))
30 (:results (res :scs (signed-reg)))
31 (:note "inline (signed-byte 64) arithmetic")
32 (:arg-types signed-num)
33 (:result-types signed-num))
35 (define-vop (fast-negate/fixnum fixnum-unop)
41 (define-vop (fast-negate/signed signed-unop)
47 (define-vop (fast-lognot/fixnum fixnum-unop)
51 (inst xor res (fixnumize -1))))
53 (define-vop (fast-lognot/signed signed-unop)
59 ;;;; binary fixnum operations
61 ;;; Assume that any constant operand is the second arg...
63 (define-vop (fast-fixnum-binop fast-safe-arith-op)
64 (:args (x :target r :scs (any-reg)
65 :load-if (not (and (sc-is x control-stack)
67 (sc-is r control-stack)
69 (y :scs (any-reg control-stack)))
70 (:arg-types tagged-num tagged-num)
71 (:results (r :scs (any-reg) :from (:argument 0)
72 :load-if (not (and (sc-is x control-stack)
74 (sc-is r control-stack)
76 (:result-types tagged-num)
77 (:note "inline fixnum arithmetic"))
79 (define-vop (fast-unsigned-binop fast-safe-arith-op)
80 (:args (x :target r :scs (unsigned-reg)
81 :load-if (not (and (sc-is x unsigned-stack)
82 (sc-is y unsigned-reg)
83 (sc-is r unsigned-stack)
85 (y :scs (unsigned-reg unsigned-stack)))
86 (:arg-types unsigned-num unsigned-num)
87 (:results (r :scs (unsigned-reg) :from (:argument 0)
88 :load-if (not (and (sc-is x unsigned-stack)
89 (sc-is y unsigned-reg)
90 (sc-is r unsigned-stack)
92 (:result-types unsigned-num)
93 (:note "inline (unsigned-byte 64) arithmetic"))
95 (define-vop (fast-signed-binop fast-safe-arith-op)
96 (:args (x :target r :scs (signed-reg)
97 :load-if (not (and (sc-is x signed-stack)
99 (sc-is r signed-stack)
101 (y :scs (signed-reg signed-stack)))
102 (:arg-types signed-num signed-num)
103 (:results (r :scs (signed-reg) :from (:argument 0)
104 :load-if (not (and (sc-is x signed-stack)
106 (sc-is r signed-stack)
108 (:result-types signed-num)
109 (:note "inline (signed-byte 64) arithmetic"))
111 (define-vop (fast-fixnum-binop-c fast-safe-arith-op)
112 (:args (x :target r :scs (any-reg)
113 :load-if (or (not (typep y '(signed-byte 29)))
114 (not (sc-is x any-reg control-stack)))))
116 (:arg-types tagged-num (:constant fixnum))
117 (:results (r :scs (any-reg)
118 :load-if (or (not (location= x r))
119 (not (typep y '(signed-byte 29))))))
120 (:result-types tagged-num)
121 (:note "inline fixnum arithmetic"))
123 (define-vop (fast-unsigned-binop-c fast-safe-arith-op)
124 (:args (x :target r :scs (unsigned-reg)
125 :load-if (or (not (typep y '(unsigned-byte 31)))
126 (not (sc-is x unsigned-reg unsigned-stack)))))
128 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
129 (:results (r :scs (unsigned-reg)
130 :load-if (or (not (location= x r))
131 (not (typep y '(unsigned-byte 31))))))
132 (:result-types unsigned-num)
133 (:note "inline (unsigned-byte 64) arithmetic"))
135 (define-vop (fast-signed-binop-c fast-safe-arith-op)
136 (:args (x :target r :scs (signed-reg)
137 :load-if (or (not (typep y '(signed-byte 32)))
138 (not (sc-is x signed-reg signed-stack)))))
140 (:arg-types signed-num (:constant (signed-byte 64)))
141 (:results (r :scs (signed-reg)
142 :load-if (or (not (location= x r))
143 (not (typep y '(signed-byte 32))))))
144 (:result-types signed-num)
145 (:note "inline (signed-byte 64) arithmetic"))
147 (macrolet ((define-binop (translate untagged-penalty op)
149 (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
151 (:translate ,translate)
155 (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
157 (:translate ,translate)
160 (inst ,op r (if (typep y '(signed-byte 29))
162 (register-inline-constant :qword (fixnumize y))))))
163 (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
165 (:translate ,translate)
166 (:generator ,(1+ untagged-penalty)
169 (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
171 (:translate ,translate)
172 (:generator ,untagged-penalty
174 (inst ,op r (if (typep y '(signed-byte 32))
176 (register-inline-constant :qword y)))))
177 (define-vop (,(symbolicate "FAST-"
179 "/UNSIGNED=>UNSIGNED")
181 (:translate ,translate)
182 (:generator ,(1+ untagged-penalty)
185 (define-vop (,(symbolicate 'fast-
187 '-c/unsigned=>unsigned)
188 fast-unsigned-binop-c)
189 (:translate ,translate)
190 (:generator ,untagged-penalty
192 (inst ,op r (if (typep y '(unsigned-byte 31))
194 (register-inline-constant :qword y))))))))
196 ;;(define-binop + 4 add)
197 (define-binop - 4 sub)
198 (define-binop logand 2 and)
199 (define-binop logior 2 or)
200 (define-binop logxor 2 xor))
202 ;;; Special handling of add on the x86; can use lea to avoid a
203 ;;; register load, otherwise it uses add.
204 (define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op)
206 (:args (x :scs (any-reg) :target r
207 :load-if (not (and (sc-is x control-stack)
209 (sc-is r control-stack)
211 (y :scs (any-reg control-stack)))
212 (:arg-types tagged-num tagged-num)
213 (:results (r :scs (any-reg) :from (:argument 0)
214 :load-if (not (and (sc-is x control-stack)
216 (sc-is r control-stack)
218 (:result-types tagged-num)
219 (:note "inline fixnum arithmetic")
221 (cond ((and (sc-is x any-reg) (sc-is y any-reg) (sc-is r any-reg)
222 (not (location= x r)))
223 (inst lea r (make-ea :qword :base x :index y :scale 1)))
228 (define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op)
230 (:args (x :target r :scs (any-reg)
231 :load-if (or (not (typep y '(signed-byte 29)))
232 (not (sc-is x any-reg control-stack)))))
234 (:arg-types tagged-num (:constant fixnum))
235 (:results (r :scs (any-reg)
236 :load-if (or (not (location= x r))
237 (not (typep y '(signed-byte 29))))))
238 (:result-types tagged-num)
239 (:note "inline fixnum arithmetic")
241 (cond ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r))
242 (typep y '(signed-byte 29)))
243 (inst lea r (make-ea :qword :base x :disp (fixnumize y))))
244 ((typep y '(signed-byte 29))
246 (inst add r (fixnumize y)))
249 (inst add r (register-inline-constant :qword (fixnumize y)))))))
251 (define-vop (fast-+/signed=>signed fast-safe-arith-op)
253 (:args (x :scs (signed-reg) :target r
254 :load-if (not (and (sc-is x signed-stack)
256 (sc-is r signed-stack)
258 (y :scs (signed-reg signed-stack)))
259 (:arg-types signed-num signed-num)
260 (:results (r :scs (signed-reg) :from (:argument 0)
261 :load-if (not (and (sc-is x signed-stack)
264 (:result-types signed-num)
265 (:note "inline (signed-byte 64) arithmetic")
267 (cond ((and (sc-is x signed-reg) (sc-is y signed-reg) (sc-is r signed-reg)
268 (not (location= x r)))
269 (inst lea r (make-ea :qword :base x :index y :scale 1)))
275 ;;;; Special logand cases: (logand signed unsigned) => unsigned
277 (define-vop (fast-logand/signed-unsigned=>unsigned
278 fast-logand/unsigned=>unsigned)
279 (:args (x :target r :scs (signed-reg)
280 :load-if (not (and (sc-is x signed-stack)
281 (sc-is y unsigned-reg)
282 (sc-is r unsigned-stack)
284 (y :scs (unsigned-reg unsigned-stack)))
285 (:arg-types signed-num unsigned-num))
287 (define-vop (fast-logand-c/signed-unsigned=>unsigned
288 fast-logand-c/unsigned=>unsigned)
289 (:args (x :target r :scs (signed-reg)
290 :load-if (or (not (typep y '(unsigned-byte 31)))
291 (not (sc-is r signed-reg signed-stack)))))
292 (:arg-types signed-num (:constant (unsigned-byte 64))))
294 (define-vop (fast-logand/unsigned-signed=>unsigned
295 fast-logand/unsigned=>unsigned)
296 (:args (x :target r :scs (unsigned-reg)
297 :load-if (not (and (sc-is x unsigned-stack)
299 (sc-is r unsigned-stack)
301 (y :scs (signed-reg signed-stack)))
302 (:arg-types unsigned-num signed-num))
305 (define-vop (fast-+-c/signed=>signed fast-safe-arith-op)
307 (:args (x :target r :scs (signed-reg)
308 :load-if (or (not (typep y '(signed-byte 32)))
309 (not (sc-is r signed-reg signed-stack)))))
311 (:arg-types signed-num (:constant (signed-byte 64)))
312 (:results (r :scs (signed-reg)
313 :load-if (or (not (location= x r))
314 (not (typep y '(signed-byte 32))))))
315 (:result-types signed-num)
316 (:note "inline (signed-byte 64) arithmetic")
318 (cond ((and (sc-is x signed-reg) (sc-is r signed-reg)
319 (not (location= x r))
320 (typep y '(signed-byte 32)))
321 (inst lea r (make-ea :qword :base x :disp y)))
326 ((typep y '(signed-byte 32))
329 (inst add r (register-inline-constant :qword y))))))))
331 (define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op)
333 (:args (x :scs (unsigned-reg) :target r
334 :load-if (not (and (sc-is x unsigned-stack)
335 (sc-is y unsigned-reg)
336 (sc-is r unsigned-stack)
338 (y :scs (unsigned-reg unsigned-stack)))
339 (:arg-types unsigned-num unsigned-num)
340 (:results (r :scs (unsigned-reg) :from (:argument 0)
341 :load-if (not (and (sc-is x unsigned-stack)
342 (sc-is y unsigned-reg)
343 (sc-is r unsigned-stack)
345 (:result-types unsigned-num)
346 (:note "inline (unsigned-byte 64) arithmetic")
348 (cond ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg)
349 (sc-is r unsigned-reg) (not (location= x r)))
350 (inst lea r (make-ea :qword :base x :index y :scale 1)))
355 (define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op)
357 (:args (x :target r :scs (unsigned-reg)
358 :load-if (or (not (typep y '(unsigned-byte 31)))
359 (not (sc-is x unsigned-reg unsigned-stack)))))
361 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
362 (:results (r :scs (unsigned-reg)
363 :load-if (or (not (location= x r))
364 (not (typep y '(unsigned-byte 31))))))
365 (:result-types unsigned-num)
366 (:note "inline (unsigned-byte 64) arithmetic")
368 (cond ((and (sc-is x unsigned-reg) (sc-is r unsigned-reg)
369 (not (location= x r))
370 (typep y '(unsigned-byte 31)))
371 (inst lea r (make-ea :qword :base x :disp y)))
376 ((typep y '(unsigned-byte 31))
379 (inst add r (register-inline-constant :qword y))))))))
381 ;;;; multiplication and division
383 (define-vop (fast-*/fixnum=>fixnum fast-safe-arith-op)
385 ;; We need different loading characteristics.
386 (:args (x :scs (any-reg) :target r)
387 (y :scs (any-reg control-stack)))
388 (:arg-types tagged-num tagged-num)
389 (:results (r :scs (any-reg) :from (:argument 0)))
390 (:result-types tagged-num)
391 (:note "inline fixnum arithmetic")
397 (define-vop (fast-*-c/fixnum=>fixnum fast-safe-arith-op)
399 ;; We need different loading characteristics.
400 (:args (x :scs (any-reg)
401 :load-if (or (not (typep y '(signed-byte 32)))
402 (not (sc-is x any-reg control-stack)))))
404 (:arg-types tagged-num (:constant fixnum))
405 (:results (r :scs (any-reg)))
406 (:result-types tagged-num)
407 (:note "inline fixnum arithmetic")
409 (cond ((typep y '(signed-byte 32))
413 (inst imul r (register-inline-constant :qword y))))))
415 (define-vop (fast-*/signed=>signed fast-safe-arith-op)
417 ;; We need different loading characteristics.
418 (:args (x :scs (signed-reg) :target r)
419 (y :scs (signed-reg signed-stack)))
420 (:arg-types signed-num signed-num)
421 (:results (r :scs (signed-reg) :from (:argument 0)))
422 (:result-types signed-num)
423 (:note "inline (signed-byte 64) arithmetic")
428 (define-vop (fast-*-c/signed=>signed fast-safe-arith-op)
430 ;; We need different loading characteristics.
431 (:args (x :scs (signed-reg)
432 :load-if (or (not (typep y '(signed-byte 32)))
433 (not (sc-is x signed-reg signed-stack)))))
435 (:arg-types signed-num (:constant (signed-byte 64)))
436 (:results (r :scs (signed-reg)))
437 (:result-types signed-num)
438 (:note "inline (signed-byte 64) arithmetic")
440 (cond ((typep y '(signed-byte 32))
444 (inst imul r (register-inline-constant :qword y))))))
446 (define-vop (fast-*/unsigned=>unsigned fast-safe-arith-op)
448 (:args (x :scs (unsigned-reg) :target eax)
449 (y :scs (unsigned-reg unsigned-stack)))
450 (:arg-types unsigned-num unsigned-num)
451 (:temporary (:sc unsigned-reg :offset eax-offset :target r
452 :from (:argument 0) :to :result) eax)
453 (:temporary (:sc unsigned-reg :offset edx-offset
454 :from :eval :to :result) edx)
456 (:results (r :scs (unsigned-reg)))
457 (:result-types unsigned-num)
458 (:note "inline (unsigned-byte 64) arithmetic")
460 (:save-p :compute-only)
466 (define-vop (fast-*-c/unsigned=>unsigned fast-safe-arith-op)
468 (:args (x :scs (unsigned-reg) :target eax))
470 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
471 (:temporary (:sc unsigned-reg :offset eax-offset :target r
472 :from (:argument 0) :to :result) eax)
473 (:temporary (:sc unsigned-reg :offset edx-offset
474 :from :eval :to :result) edx)
476 (:results (r :scs (unsigned-reg)))
477 (:result-types unsigned-num)
478 (:note "inline (unsigned-byte 64) arithmetic")
480 (:save-p :compute-only)
483 (inst mul eax (register-inline-constant :qword y))
487 (define-vop (fast-truncate/fixnum=>fixnum fast-safe-arith-op)
488 (:translate truncate)
489 (:args (x :scs (any-reg) :target eax)
490 (y :scs (any-reg control-stack)))
491 (:arg-types tagged-num tagged-num)
492 (:temporary (:sc signed-reg :offset eax-offset :target quo
493 :from (:argument 0) :to (:result 0)) eax)
494 (:temporary (:sc unsigned-reg :offset edx-offset :target rem
495 :from (:argument 0) :to (:result 1)) edx)
496 (:results (quo :scs (any-reg))
497 (rem :scs (any-reg)))
498 (:result-types tagged-num tagged-num)
499 (:note "inline fixnum arithmetic")
501 (:save-p :compute-only)
503 (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
504 (if (sc-is y any-reg)
505 (inst test y y) ; smaller instruction
511 (if (location= quo eax)
512 (inst shl eax n-fixnum-tag-bits)
513 (inst lea quo (make-ea :qword :index eax
514 :scale (ash 1 n-fixnum-tag-bits))))
517 (define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
518 (:translate truncate)
519 (:args (x :scs (any-reg) :target eax))
521 (:arg-types tagged-num (:constant fixnum))
522 (:temporary (:sc signed-reg :offset eax-offset :target quo
523 :from :argument :to (:result 0)) eax)
524 (:temporary (:sc any-reg :offset edx-offset :target rem
525 :from :eval :to (:result 1)) edx)
526 (:temporary (:sc any-reg :from :eval :to :result) y-arg)
527 (:results (quo :scs (any-reg))
528 (rem :scs (any-reg)))
529 (:result-types tagged-num tagged-num)
530 (:note "inline fixnum arithmetic")
532 (:save-p :compute-only)
536 (if (typep y '(signed-byte 29))
537 (inst mov y-arg (fixnumize y))
538 (setf y-arg (register-inline-constant :qword (fixnumize y))))
539 (inst idiv eax y-arg)
540 (if (location= quo eax)
541 (inst shl eax n-fixnum-tag-bits)
542 (inst lea quo (make-ea :qword :index eax
543 :scale (ash 1 n-fixnum-tag-bits))))
546 (define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
547 (:translate truncate)
548 (:args (x :scs (unsigned-reg) :target eax)
549 (y :scs (unsigned-reg signed-stack)))
550 (:arg-types unsigned-num unsigned-num)
551 (:temporary (:sc unsigned-reg :offset eax-offset :target quo
552 :from (:argument 0) :to (:result 0)) eax)
553 (:temporary (:sc unsigned-reg :offset edx-offset :target rem
554 :from (:argument 0) :to (:result 1)) edx)
555 (:results (quo :scs (unsigned-reg))
556 (rem :scs (unsigned-reg)))
557 (:result-types unsigned-num unsigned-num)
558 (:note "inline (unsigned-byte 64) arithmetic")
560 (:save-p :compute-only)
562 (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
563 (if (sc-is y unsigned-reg)
564 (inst test y y) ; smaller instruction
573 (define-vop (fast-truncate-c/unsigned=>unsigned fast-safe-arith-op)
574 (:translate truncate)
575 (:args (x :scs (unsigned-reg) :target eax))
577 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
578 (:temporary (:sc unsigned-reg :offset eax-offset :target quo
579 :from :argument :to (:result 0)) eax)
580 (:temporary (:sc unsigned-reg :offset edx-offset :target rem
581 :from :eval :to (:result 1)) edx)
582 (:temporary (:sc unsigned-reg :from :eval :to :result) y-arg)
583 (:results (quo :scs (unsigned-reg))
584 (rem :scs (unsigned-reg)))
585 (:result-types unsigned-num unsigned-num)
586 (:note "inline (unsigned-byte 64) arithmetic")
588 (:save-p :compute-only)
592 (if (typep y '(unsigned-byte 31))
594 (setf y-arg (register-inline-constant :qword y)))
599 (define-vop (fast-truncate/signed=>signed fast-safe-arith-op)
600 (:translate truncate)
601 (:args (x :scs (signed-reg) :target eax)
602 (y :scs (signed-reg signed-stack)))
603 (:arg-types signed-num signed-num)
604 (:temporary (:sc signed-reg :offset eax-offset :target quo
605 :from (:argument 0) :to (:result 0)) eax)
606 (:temporary (:sc signed-reg :offset edx-offset :target rem
607 :from (:argument 0) :to (:result 1)) edx)
608 (:results (quo :scs (signed-reg))
609 (rem :scs (signed-reg)))
610 (:result-types signed-num signed-num)
611 (:note "inline (signed-byte 64) arithmetic")
613 (:save-p :compute-only)
615 (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
616 (if (sc-is y signed-reg)
617 (inst test y y) ; smaller instruction
626 (define-vop (fast-truncate-c/signed=>signed fast-safe-arith-op)
627 (:translate truncate)
628 (:args (x :scs (signed-reg) :target eax))
630 (:arg-types signed-num (:constant (signed-byte 64)))
631 (:temporary (:sc signed-reg :offset eax-offset :target quo
632 :from :argument :to (:result 0)) eax)
633 (:temporary (:sc signed-reg :offset edx-offset :target rem
634 :from :eval :to (:result 1)) edx)
635 (:temporary (:sc signed-reg :from :eval :to :result) y-arg)
636 (:results (quo :scs (signed-reg))
637 (rem :scs (signed-reg)))
638 (:result-types signed-num signed-num)
639 (:note "inline (signed-byte 64) arithmetic")
641 (:save-p :compute-only)
645 (if (typep y '(signed-byte 32))
647 (setf y-arg (register-inline-constant :qword y)))
648 (inst idiv eax y-arg)
655 (define-vop (fast-ash-c/fixnum=>fixnum)
658 (:args (number :scs (any-reg) :target result
659 :load-if (not (and (sc-is number any-reg control-stack)
660 (sc-is result any-reg control-stack)
661 (location= number result)))))
663 (:arg-types tagged-num (:constant integer))
664 (:results (result :scs (any-reg)
665 :load-if (not (and (sc-is number control-stack)
666 (sc-is result control-stack)
667 (location= number result)))))
668 (:result-types tagged-num)
671 (cond ((and (= amount 1) (not (location= number result)))
672 (inst lea result (make-ea :qword :base number :index number)))
673 ((and (= amount 2) (not (location= number result)))
674 (inst lea result (make-ea :qword :index number :scale 4)))
675 ((and (= amount 3) (not (location= number result)))
676 (inst lea result (make-ea :qword :index number :scale 8)))
679 (cond ((< -64 amount 64)
680 ;; this code is used both in ASH and ASH-SMOD61, so
683 (inst shl result amount)
685 (inst sar result (- amount))
686 (inst and result (lognot fixnum-tag-mask)))))
688 (if (sc-is result any-reg)
689 (inst xor result result)
690 (inst mov result 0)))
691 (t (inst sar result 63)
692 (inst and result (lognot fixnum-tag-mask))))))))
694 (define-vop (fast-ash-left/fixnum=>fixnum)
696 (:args (number :scs (any-reg) :target result
697 :load-if (not (and (sc-is number control-stack)
698 (sc-is result control-stack)
699 (location= number result))))
700 (amount :scs (unsigned-reg) :target ecx))
701 (:arg-types tagged-num positive-fixnum)
702 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
703 (:results (result :scs (any-reg) :from (:argument 0)
704 :load-if (not (and (sc-is number control-stack)
705 (sc-is result control-stack)
706 (location= number result)))))
707 (:result-types tagged-num)
713 ;; The result-type ensures us that this shift will not overflow.
714 (inst shl result :cl)))
716 (define-vop (fast-ash-c/signed=>signed)
719 (:args (number :scs (signed-reg) :target result
720 :load-if (not (and (sc-is number signed-stack)
721 (sc-is result signed-stack)
722 (location= number result)))))
724 (:arg-types signed-num (:constant integer))
725 (:results (result :scs (signed-reg)
726 :load-if (not (and (sc-is number signed-stack)
727 (sc-is result signed-stack)
728 (location= number result)))))
729 (:result-types signed-num)
732 (cond ((and (= amount 1) (not (location= number result)))
733 (inst lea result (make-ea :qword :base number :index number)))
734 ((and (= amount 2) (not (location= number result)))
735 (inst lea result (make-ea :qword :index number :scale 4)))
736 ((and (= amount 3) (not (location= number result)))
737 (inst lea result (make-ea :qword :index number :scale 8)))
740 (cond ((plusp amount) (inst shl result amount))
741 (t (inst sar result (min 63 (- amount)))))))))
743 (define-vop (fast-ash-c/unsigned=>unsigned)
746 (:args (number :scs (unsigned-reg) :target result
747 :load-if (not (and (sc-is number unsigned-stack)
748 (sc-is result unsigned-stack)
749 (location= number result)))))
751 (:arg-types unsigned-num (:constant integer))
752 (:results (result :scs (unsigned-reg)
753 :load-if (not (and (sc-is number unsigned-stack)
754 (sc-is result unsigned-stack)
755 (location= number result)))))
756 (:result-types unsigned-num)
759 (cond ((and (= amount 1) (not (location= number result)))
760 (inst lea result (make-ea :qword :base number :index number)))
761 ((and (= amount 2) (not (location= number result)))
762 (inst lea result (make-ea :qword :index number :scale 4)))
763 ((and (= amount 3) (not (location= number result)))
764 (inst lea result (make-ea :qword :index number :scale 8)))
767 (cond ((< -64 amount 64) ;; XXXX
768 ;; this code is used both in ASH and ASH-MOD32, so
771 (inst shl result amount)
772 (inst shr result (- amount))))
773 (t (if (sc-is result unsigned-reg)
775 (inst mov result 0))))))))
777 (define-vop (fast-ash-left/signed=>signed)
779 (:args (number :scs (signed-reg) :target result
780 :load-if (not (and (sc-is number signed-stack)
781 (sc-is result signed-stack)
782 (location= number result))))
783 (amount :scs (unsigned-reg) :target ecx))
784 (:arg-types signed-num positive-fixnum)
785 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
786 (:results (result :scs (signed-reg) :from (:argument 0)
787 :load-if (not (and (sc-is number signed-stack)
788 (sc-is result signed-stack)
789 (location= number result)))))
790 (:result-types signed-num)
796 (inst shl result :cl)))
798 (define-vop (fast-ash-left/unsigned=>unsigned)
800 (:args (number :scs (unsigned-reg) :target result
801 :load-if (not (and (sc-is number unsigned-stack)
802 (sc-is result unsigned-stack)
803 (location= number result))))
804 (amount :scs (unsigned-reg) :target ecx))
805 (:arg-types unsigned-num positive-fixnum)
806 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
807 (:results (result :scs (unsigned-reg) :from (:argument 0)
808 :load-if (not (and (sc-is number unsigned-stack)
809 (sc-is result unsigned-stack)
810 (location= number result)))))
811 (:result-types unsigned-num)
817 (inst shl result :cl)))
819 (define-vop (fast-ash/signed=>signed)
822 (:args (number :scs (signed-reg) :target result)
823 (amount :scs (signed-reg) :target ecx))
824 (:arg-types signed-num signed-num)
825 (:results (result :scs (signed-reg) :from (:argument 0)))
826 (:result-types signed-num)
827 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
833 (inst jmp :ns POSITIVE)
839 (inst sar result :cl)
843 ;; The result-type ensures us that this shift will not overflow.
844 (inst shl result :cl)
848 (define-vop (fast-ash/unsigned=>unsigned)
851 (:args (number :scs (unsigned-reg) :target result)
852 (amount :scs (signed-reg) :target ecx))
853 (:arg-types unsigned-num signed-num)
854 (:results (result :scs (unsigned-reg) :from (:argument 0)))
855 (:result-types unsigned-num)
856 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
862 (inst jmp :ns POSITIVE)
869 (inst shr result :cl)
873 ;; The result-type ensures us that this shift will not overflow.
874 (inst shl result :cl)
880 (defknown %lea (integer integer (member 1 2 4 8 16) (signed-byte 64))
882 (foldable flushable movable))
884 (defoptimizer (%lea derive-type) ((base index scale disp))
885 (when (and (constant-lvar-p scale)
886 (constant-lvar-p disp))
887 (let ((scale (lvar-value scale))
888 (disp (lvar-value disp))
889 (base-type (lvar-type base))
890 (index-type (lvar-type index)))
891 (when (and (numeric-type-p base-type)
892 (numeric-type-p index-type))
893 (let ((base-lo (numeric-type-low base-type))
894 (base-hi (numeric-type-high base-type))
895 (index-lo (numeric-type-low index-type))
896 (index-hi (numeric-type-high index-type)))
897 (make-numeric-type :class 'integer
899 :low (when (and base-lo index-lo)
900 (+ base-lo (* index-lo scale) disp))
901 :high (when (and base-hi index-hi)
902 (+ base-hi (* index-hi scale) disp))))))))
904 (defun %lea (base index scale disp)
905 (+ base (* index scale) disp))
909 (define-vop (%lea/unsigned=>unsigned)
912 (:args (base :scs (unsigned-reg))
913 (index :scs (unsigned-reg)))
915 (:arg-types unsigned-num unsigned-num
916 (:constant (member 1 2 4 8))
917 (:constant (signed-byte 64)))
918 (:results (r :scs (unsigned-reg)))
919 (:result-types unsigned-num)
921 (inst lea r (make-ea :qword :base base :index index
922 :scale scale :disp disp))))
924 (define-vop (%lea/signed=>signed)
927 (:args (base :scs (signed-reg))
928 (index :scs (signed-reg)))
930 (:arg-types signed-num signed-num
931 (:constant (member 1 2 4 8))
932 (:constant (signed-byte 64)))
933 (:results (r :scs (signed-reg)))
934 (:result-types signed-num)
936 (inst lea r (make-ea :qword :base base :index index
937 :scale scale :disp disp))))
939 (define-vop (%lea/fixnum=>fixnum)
942 (:args (base :scs (any-reg))
943 (index :scs (any-reg)))
945 (:arg-types tagged-num tagged-num
946 (:constant (member 1 2 4 8))
947 (:constant (signed-byte 64)))
948 (:results (r :scs (any-reg)))
949 (:result-types tagged-num)
951 (inst lea r (make-ea :qword :base base :index index
952 :scale scale :disp disp))))
954 ;;; FIXME: before making knowledge of this too public, it needs to be
955 ;;; fixed so that it's actually _faster_ than the non-CMOV version; at
956 ;;; least on my Celeron-XXX laptop, this version is marginally slower
957 ;;; than the above version with branches. -- CSR, 2003-09-04
958 (define-vop (fast-cmov-ash/unsigned=>unsigned)
961 (:args (number :scs (unsigned-reg) :target result)
962 (amount :scs (signed-reg) :target ecx))
963 (:arg-types unsigned-num signed-num)
964 (:results (result :scs (unsigned-reg) :from (:argument 0)))
965 (:result-types unsigned-num)
966 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
967 (:temporary (:sc any-reg :from (:eval 0) :to (:eval 1)) zero)
969 (:guard (member :cmov *backend-subfeatures*))
974 (inst jmp :ns POSITIVE)
977 (inst shr result :cl)
979 (inst cmov :nbe result zero)
983 ;; The result-type ensures us that this shift will not overflow.
984 (inst shl result :cl)
988 (define-vop (signed-byte-64-len)
989 (:translate integer-length)
990 (:note "inline (signed-byte 64) integer-length")
992 (:args (arg :scs (signed-reg) :target res))
993 (:arg-types signed-num)
994 (:results (res :scs (unsigned-reg)))
995 (:result-types unsigned-num)
998 (if (sc-is res unsigned-reg)
1012 (define-vop (unsigned-byte-64-len)
1013 (:translate integer-length)
1014 (:note "inline (unsigned-byte 64) integer-length")
1015 (:policy :fast-safe)
1016 (:args (arg :scs (unsigned-reg)))
1017 (:arg-types unsigned-num)
1018 (:results (res :scs (unsigned-reg)))
1019 (:result-types unsigned-num)
1029 (define-vop (unsigned-byte-64-count)
1030 (:translate logcount)
1031 (:note "inline (unsigned-byte 64) logcount")
1032 (:policy :fast-safe)
1033 (:args (arg :scs (unsigned-reg) :target result))
1034 (:arg-types unsigned-num)
1035 (:results (result :scs (unsigned-reg)))
1036 (:result-types positive-fixnum)
1037 (:temporary (:sc unsigned-reg) temp)
1038 (:temporary (:sc unsigned-reg) mask)
1040 ;; See the comments below for how the algorithm works. The tricks
1041 ;; used can be found for example in AMD's software optimization
1042 ;; guide or at "http://www.hackersdelight.org/HDcode/pop.cc" in the
1043 ;; function "pop1", for 32-bit words. The extension to 64 bits is
1045 ;; Calculate 2-bit sums. Note that the value of a two-digit binary
1046 ;; number is the sum of the right digit and twice the left digit.
1047 ;; Thus we can calculate the sum of the two digits by shifting the
1048 ;; left digit to the right position and doing a two-bit subtraction.
1049 ;; This subtraction will never create a borrow and thus can be made
1050 ;; on all 32 2-digit numbers at once.
1054 (inst mov mask #x5555555555555555)
1055 (inst and result mask)
1056 (inst sub temp result)
1057 ;; Calculate 4-bit sums by straightforward shift, mask and add.
1058 ;; Note that we shift the source operand of the MOV and not its
1059 ;; destination so that the SHR and the MOV can execute in the same
1061 (inst mov result temp)
1063 (inst mov mask #x3333333333333333)
1064 (inst and result mask)
1065 (inst and temp mask)
1066 (inst add result temp)
1067 ;; Calculate 8-bit sums. Since each sum is at most 8, which fits
1068 ;; into 4 bits, we can apply the mask after the addition, saving one
1070 (inst mov temp result)
1072 (inst add result temp)
1073 (inst mov mask #x0f0f0f0f0f0f0f0f)
1074 (inst and result mask)
1075 ;; Add all 8 bytes at once by multiplying with #256r11111111.
1076 ;; We need to calculate only the lower 8 bytes of the product.
1077 ;; Of these the most significant byte contains the final result.
1078 ;; Note that there can be no overflow from one byte to the next
1079 ;; as the sum is at most 64 which needs only 7 bits.
1080 (inst mov mask #x0101010101010101)
1081 (inst imul result mask)
1082 (inst shr result 56)))
1084 ;;;; binary conditional VOPs
1086 (define-vop (fast-conditional)
1091 (:policy :fast-safe))
1093 ;;; constant variants are declared for 32 bits not 64 bits, because
1094 ;;; loading a 64 bit constant is silly
1096 (define-vop (fast-conditional/fixnum fast-conditional)
1097 (:args (x :scs (any-reg)
1098 :load-if (not (and (sc-is x control-stack)
1099 (sc-is y any-reg))))
1100 (y :scs (any-reg control-stack)))
1101 (:arg-types tagged-num tagged-num)
1102 (:note "inline fixnum comparison"))
1104 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
1105 (:args (x :scs (any-reg)
1106 :load-if (or (not (typep y '(signed-byte 29)))
1107 (not (sc-is x any-reg control-stack)))))
1108 (:arg-types tagged-num (:constant fixnum))
1111 (define-vop (fast-conditional/signed fast-conditional)
1112 (:args (x :scs (signed-reg)
1113 :load-if (not (and (sc-is x signed-stack)
1114 (sc-is y signed-reg))))
1115 (y :scs (signed-reg signed-stack)))
1116 (:arg-types signed-num signed-num)
1117 (:note "inline (signed-byte 64) comparison"))
1119 (define-vop (fast-conditional-c/signed fast-conditional/signed)
1120 (:args (x :scs (signed-reg)
1121 :load-if (or (not (typep y '(signed-byte 32)))
1122 (not (sc-is x signed-reg signed-stack)))))
1123 (:arg-types signed-num (:constant (signed-byte 64)))
1126 (define-vop (fast-conditional/unsigned fast-conditional)
1127 (:args (x :scs (unsigned-reg)
1128 :load-if (not (and (sc-is x unsigned-stack)
1129 (sc-is y unsigned-reg))))
1130 (y :scs (unsigned-reg unsigned-stack)))
1131 (:arg-types unsigned-num unsigned-num)
1132 (:note "inline (unsigned-byte 64) comparison"))
1134 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
1135 (:args (x :scs (unsigned-reg)
1136 :load-if (or (not (typep y '(unsigned-byte 31)))
1137 (not (sc-is x unsigned-reg unsigned-stack)))))
1138 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
1141 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
1144 (lambda (suffix cost signed)
1145 `(define-vop (;; FIXME: These could be done more
1146 ;; cleanly with SYMBOLICATE.
1147 ,(intern (format nil "~:@(FAST-IF-~A~A~)"
1150 (format nil "~:@(FAST-CONDITIONAL~A~)"
1153 (:conditional ,(if signed cond unsigned))
1158 `(if (typep y '(signed-byte 29))
1160 (register-inline-constant
1161 :qword (fixnumize y))))
1163 `(if (typep y '(signed-byte 32))
1165 (register-inline-constant
1168 `(if (typep y '(unsigned-byte 31))
1170 (register-inline-constant
1173 '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
1174 ; '(/fixnum /signed /unsigned)
1176 '(t t t t nil nil)))))
1178 (define-conditional-vop < :l :b :ge :ae)
1179 (define-conditional-vop > :g :a :le :be))
1181 (define-vop (fast-if-eql/signed fast-conditional/signed)
1186 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
1189 (cond ((and (sc-is x signed-reg) (zerop y))
1190 (inst test x x)) ; smaller instruction
1191 ((typep y '(signed-byte 32))
1194 (inst cmp x (register-inline-constant :qword y))))))
1196 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
1201 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
1204 (cond ((and (sc-is x unsigned-reg) (zerop y))
1205 (inst test x x)) ; smaller instruction
1206 ((typep y '(unsigned-byte 31))
1209 (inst cmp x (register-inline-constant :qword y))))))
1211 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
1214 ;;; These versions specify a fixnum restriction on their first arg. We have
1215 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
1216 ;;; the first arg and a higher cost. The reason for doing this is to prevent
1217 ;;; fixnum specific operations from being used on word integers, spuriously
1218 ;;; consing the argument.
1220 (define-vop (fast-eql/fixnum fast-conditional)
1221 (:args (x :scs (any-reg)
1222 :load-if (not (and (sc-is x control-stack)
1223 (sc-is y any-reg))))
1224 (y :scs (any-reg control-stack)))
1225 (:arg-types tagged-num tagged-num)
1226 (:note "inline fixnum comparison")
1231 (define-vop (generic-eql/fixnum fast-eql/fixnum)
1232 (:args (x :scs (any-reg descriptor-reg)
1233 :load-if (not (and (sc-is x control-stack)
1234 (sc-is y any-reg))))
1235 (y :scs (any-reg control-stack)))
1236 (:arg-types * tagged-num)
1239 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
1240 (:args (x :scs (any-reg)
1241 :load-if (or (not (typep y '(signed-byte 29)))
1242 (not (sc-is x any-reg descriptor-reg control-stack)))))
1243 (:arg-types tagged-num (:constant fixnum))
1247 (cond ((and (sc-is x any-reg descriptor-reg) (zerop y))
1248 (inst test x x)) ; smaller instruction
1249 ((typep y '(signed-byte 29))
1250 (inst cmp x (fixnumize y)))
1252 (inst cmp x (register-inline-constant :qword (fixnumize y)))))))
1254 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
1255 (:args (x :scs (any-reg descriptor-reg)))
1256 (:arg-types * (:constant fixnum))
1259 ;;;; 32-bit logical operations
1261 ;;; Only the lower 6 bits of the shift amount are significant.
1262 (define-vop (shift-towards-someplace)
1263 (:policy :fast-safe)
1264 (:args (num :scs (unsigned-reg) :target r)
1265 (amount :scs (signed-reg) :target ecx))
1266 (:arg-types unsigned-num tagged-num)
1267 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
1268 (:results (r :scs (unsigned-reg) :from (:argument 0)))
1269 (:result-types unsigned-num))
1271 (define-vop (shift-towards-start shift-towards-someplace)
1272 (:translate shift-towards-start)
1273 (:note "SHIFT-TOWARDS-START")
1279 (define-vop (shift-towards-end shift-towards-someplace)
1280 (:translate shift-towards-end)
1281 (:note "SHIFT-TOWARDS-END")
1287 ;;;; Modular functions
1289 (defmacro define-mod-binop ((name prototype) function)
1290 `(define-vop (,name ,prototype)
1291 (:args (x :target r :scs (unsigned-reg signed-reg)
1292 :load-if (not (and (or (sc-is x unsigned-stack)
1293 (sc-is x signed-stack))
1294 (or (sc-is y unsigned-reg)
1295 (sc-is y signed-reg))
1296 (or (sc-is r unsigned-stack)
1297 (sc-is r signed-stack))
1299 (y :scs (unsigned-reg signed-reg unsigned-stack signed-stack)))
1300 (:arg-types untagged-num untagged-num)
1301 (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1302 :load-if (not (and (or (sc-is x unsigned-stack)
1303 (sc-is x signed-stack))
1304 (or (sc-is y unsigned-reg)
1305 (sc-is y unsigned-reg))
1306 (or (sc-is r unsigned-stack)
1307 (sc-is r unsigned-stack))
1309 (:result-types unsigned-num)
1310 (:translate ,function)))
1311 (defmacro define-mod-binop-c ((name prototype) function)
1312 `(define-vop (,name ,prototype)
1313 (:args (x :target r :scs (unsigned-reg signed-reg)
1314 :load-if (not (and (or (sc-is x unsigned-stack)
1315 (sc-is x signed-stack))
1316 (or (sc-is r unsigned-stack)
1317 (sc-is r signed-stack))
1319 (typep y '(signed-byte 32))))))
1321 (:arg-types untagged-num (:constant (or (unsigned-byte 64) (signed-byte 64))))
1322 (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1323 :load-if (not (and (or (sc-is x unsigned-stack)
1324 (sc-is x signed-stack))
1325 (or (sc-is r unsigned-stack)
1326 (sc-is r unsigned-stack))
1328 (:result-types unsigned-num)
1329 (:translate ,function)))
1331 (macrolet ((def (name -c-p)
1332 (let ((fun64 (intern (format nil "~S-MOD64" name)))
1333 (vopu (intern (format nil "FAST-~S/UNSIGNED=>UNSIGNED" name)))
1334 (vopcu (intern (format nil "FAST-~S-C/UNSIGNED=>UNSIGNED" name)))
1335 (vopf (intern (format nil "FAST-~S/FIXNUM=>FIXNUM" name)))
1336 (vopcf (intern (format nil "FAST-~S-C/FIXNUM=>FIXNUM" name)))
1337 (vop64u (intern (format nil "FAST-~S-MOD64/WORD=>UNSIGNED" name)))
1338 (vop64f (intern (format nil "FAST-~S-MOD64/FIXNUM=>FIXNUM" name)))
1339 (vop64cu (intern (format nil "FAST-~S-MOD64-C/WORD=>UNSIGNED" name)))
1340 (vop64cf (intern (format nil "FAST-~S-MOD64-C/FIXNUM=>FIXNUM" name)))
1341 (sfun61 (intern (format nil "~S-SMOD61" name)))
1342 (svop61f (intern (format nil "FAST-~S-SMOD61/FIXNUM=>FIXNUM" name)))
1343 (svop61cf (intern (format nil "FAST-~S-SMOD61-C/FIXNUM=>FIXNUM" name))))
1345 (define-modular-fun ,fun64 (x y) ,name :untagged nil 64)
1346 (define-modular-fun ,sfun61 (x y) ,name :tagged t 61)
1347 (define-mod-binop (,vop64u ,vopu) ,fun64)
1348 (define-vop (,vop64f ,vopf) (:translate ,fun64))
1349 (define-vop (,svop61f ,vopf) (:translate ,sfun61))
1351 `((define-mod-binop-c (,vop64cu ,vopcu) ,fun64)
1352 (define-vop (,svop61cf ,vopcf) (:translate ,sfun61))))))))
1357 (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
1358 fast-ash-c/unsigned=>unsigned)
1359 (:translate ash-left-mod64))
1360 (define-vop (fast-ash-left-mod64/unsigned=>unsigned
1361 fast-ash-left/unsigned=>unsigned))
1362 (deftransform ash-left-mod64 ((integer count)
1363 ((unsigned-byte 64) (unsigned-byte 6)))
1364 (when (sb!c::constant-lvar-p count)
1365 (sb!c::give-up-ir1-transform))
1366 '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
1368 (define-vop (fast-ash-left-smod61-c/fixnum=>fixnum
1369 fast-ash-c/fixnum=>fixnum)
1370 (:translate ash-left-smod61))
1371 (define-vop (fast-ash-left-smod61/fixnum=>fixnum
1372 fast-ash-left/fixnum=>fixnum))
1373 (deftransform ash-left-smod61 ((integer count)
1374 ((signed-byte 61) (unsigned-byte 6)))
1375 (when (sb!c::constant-lvar-p count)
1376 (sb!c::give-up-ir1-transform))
1377 '(%primitive fast-ash-left-smod61/fixnum=>fixnum integer count))
1381 (defknown sb!vm::%lea-mod64 (integer integer (member 1 2 4 8) (signed-byte 64))
1383 (foldable flushable movable))
1384 (defknown sb!vm::%lea-smod61 (integer integer (member 1 2 4 8) (signed-byte 64))
1386 (foldable flushable movable))
1388 (define-modular-fun-optimizer %lea ((base index scale disp) :untagged nil :width width)
1389 (when (and (<= width 64)
1390 (constant-lvar-p scale)
1391 (constant-lvar-p disp))
1392 (cut-to-width base :untagged width nil)
1393 (cut-to-width index :untagged width nil)
1394 'sb!vm::%lea-mod64))
1395 (define-modular-fun-optimizer %lea ((base index scale disp) :tagged t :width width)
1396 (when (and (<= width 61)
1397 (constant-lvar-p scale)
1398 (constant-lvar-p disp))
1399 (cut-to-width base :tagged width t)
1400 (cut-to-width index :tagged width t)
1401 'sb!vm::%lea-smod61))
1405 (defun sb!vm::%lea-mod64 (base index scale disp)
1406 (ldb (byte 64 0) (%lea base index scale disp)))
1407 (defun sb!vm::%lea-smod61 (base index scale disp)
1408 (mask-signed-field 61 (%lea base index scale disp))))
1411 (defun sb!vm::%lea-mod64 (base index scale disp)
1412 (let ((base (logand base #xffffffffffffffff))
1413 (index (logand index #xffffffffffffffff)))
1414 ;; can't use modular version of %LEA, as we only have VOPs for
1415 ;; constant SCALE and DISP.
1416 (ldb (byte 64 0) (+ base (* index scale) disp))))
1417 (defun sb!vm::%lea-smod61 (base index scale disp)
1418 (let ((base (mask-signed-field 61 base))
1419 (index (mask-signed-field 61 index)))
1420 ;; can't use modular version of %LEA, as we only have VOPs for
1421 ;; constant SCALE and DISP.
1422 (mask-signed-field 61 (+ base (* index scale) disp)))))
1424 (in-package "SB!VM")
1426 (define-vop (%lea-mod64/unsigned=>unsigned
1427 %lea/unsigned=>unsigned)
1428 (:translate %lea-mod64))
1429 (define-vop (%lea-smod61/fixnum=>fixnum
1430 %lea/fixnum=>fixnum)
1431 (:translate %lea-smod61))
1433 ;;; logical operations
1434 (define-modular-fun lognot-mod64 (x) lognot :untagged nil 64)
1435 (define-vop (lognot-mod64/unsigned=>unsigned)
1436 (:translate lognot-mod64)
1437 (:args (x :scs (unsigned-reg unsigned-stack) :target r
1438 :load-if (not (and (sc-is x unsigned-stack)
1439 (sc-is r unsigned-stack)
1441 (:arg-types unsigned-num)
1442 (:results (r :scs (unsigned-reg)
1443 :load-if (not (and (sc-is x unsigned-stack)
1444 (sc-is r unsigned-stack)
1446 (:result-types unsigned-num)
1447 (:policy :fast-safe)
1452 (define-source-transform logeqv (&rest args)
1453 (if (oddp (length args))
1455 `(lognot (logxor ,@args))))
1456 (define-source-transform logandc1 (x y)
1457 `(logand (lognot ,x) ,y))
1458 (define-source-transform logandc2 (x y)
1459 `(logand ,x (lognot ,y)))
1460 (define-source-transform logorc1 (x y)
1461 `(logior (lognot ,x) ,y))
1462 (define-source-transform logorc2 (x y)
1463 `(logior ,x (lognot ,y)))
1464 (define-source-transform lognor (x y)
1465 `(lognot (logior ,x ,y)))
1466 (define-source-transform lognand (x y)
1467 `(lognot (logand ,x ,y)))
1471 (define-vop (bignum-length get-header-data)
1472 (:translate sb!bignum:%bignum-length)
1473 (:policy :fast-safe))
1475 (define-vop (bignum-set-length set-header-data)
1476 (:translate sb!bignum:%bignum-set-length)
1477 (:policy :fast-safe))
1479 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
1480 (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
1481 (define-full-reffer+offset bignum--ref-with-offset * bignum-digits-offset
1482 other-pointer-lowtag (unsigned-reg) unsigned-num
1483 sb!bignum:%bignum-ref-with-offset)
1484 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
1485 (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
1487 (define-vop (digit-0-or-plus)
1488 (:translate sb!bignum:%digit-0-or-plusp)
1489 (:policy :fast-safe)
1490 (:args (digit :scs (unsigned-reg)))
1491 (:arg-types unsigned-num)
1494 (inst or digit digit)))
1497 ;;; For add and sub with carry the sc of carry argument is any-reg so
1498 ;;; that it may be passed as a fixnum or word and thus may be 0, 1, or
1499 ;;; 8. This is easy to deal with and may save a fixnum-word
1501 (define-vop (add-w/carry)
1502 (:translate sb!bignum:%add-with-carry)
1503 (:policy :fast-safe)
1504 (:args (a :scs (unsigned-reg) :target result)
1505 (b :scs (unsigned-reg unsigned-stack) :to :eval)
1506 (c :scs (any-reg) :target temp))
1507 (:arg-types unsigned-num unsigned-num positive-fixnum)
1508 (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
1509 (:results (result :scs (unsigned-reg) :from (:argument 0))
1510 (carry :scs (unsigned-reg)))
1511 (:result-types unsigned-num positive-fixnum)
1515 (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
1518 (inst adc carry carry)))
1520 ;;; Note: the borrow is 1 for no borrow and 0 for a borrow, the opposite
1521 ;;; of the x86-64 convention.
1522 (define-vop (sub-w/borrow)
1523 (:translate sb!bignum:%subtract-with-borrow)
1524 (:policy :fast-safe)
1525 (:args (a :scs (unsigned-reg) :to :eval :target result)
1526 (b :scs (unsigned-reg unsigned-stack) :to :result)
1527 (c :scs (any-reg control-stack)))
1528 (:arg-types unsigned-num unsigned-num positive-fixnum)
1529 (:results (result :scs (unsigned-reg) :from :eval)
1530 (borrow :scs (unsigned-reg)))
1531 (:result-types unsigned-num positive-fixnum)
1533 (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
1537 (inst sbb borrow 0)))
1540 (define-vop (bignum-mult-and-add-3-arg)
1541 (:translate sb!bignum:%multiply-and-add)
1542 (:policy :fast-safe)
1543 (:args (x :scs (unsigned-reg) :target eax)
1544 (y :scs (unsigned-reg unsigned-stack))
1545 (carry-in :scs (unsigned-reg unsigned-stack)))
1546 (:arg-types unsigned-num unsigned-num unsigned-num)
1547 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1548 :to (:result 1) :target lo) eax)
1549 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1550 :to (:result 0) :target hi) edx)
1551 (:results (hi :scs (unsigned-reg))
1552 (lo :scs (unsigned-reg)))
1553 (:result-types unsigned-num unsigned-num)
1557 (inst add eax carry-in)
1562 (define-vop (bignum-mult-and-add-4-arg)
1563 (:translate sb!bignum:%multiply-and-add)
1564 (:policy :fast-safe)
1565 (:args (x :scs (unsigned-reg) :target eax)
1566 (y :scs (unsigned-reg unsigned-stack))
1567 (prev :scs (unsigned-reg unsigned-stack))
1568 (carry-in :scs (unsigned-reg unsigned-stack)))
1569 (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1570 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1571 :to (:result 1) :target lo) eax)
1572 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1573 :to (:result 0) :target hi) edx)
1574 (:results (hi :scs (unsigned-reg))
1575 (lo :scs (unsigned-reg)))
1576 (:result-types unsigned-num unsigned-num)
1582 (inst add eax carry-in)
1588 (define-vop (bignum-mult)
1589 (:translate sb!bignum:%multiply)
1590 (:policy :fast-safe)
1591 (:args (x :scs (unsigned-reg) :target eax)
1592 (y :scs (unsigned-reg unsigned-stack)))
1593 (:arg-types unsigned-num unsigned-num)
1594 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1595 :to (:result 1) :target lo) eax)
1596 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1597 :to (:result 0) :target hi) edx)
1598 (:results (hi :scs (unsigned-reg))
1599 (lo :scs (unsigned-reg)))
1600 (:result-types unsigned-num unsigned-num)
1607 (define-vop (bignum-lognot lognot-mod64/unsigned=>unsigned)
1608 (:translate sb!bignum:%lognot))
1610 (define-vop (fixnum-to-digit)
1611 (:translate sb!bignum:%fixnum-to-digit)
1612 (:policy :fast-safe)
1613 (:args (fixnum :scs (any-reg control-stack) :target digit))
1614 (:arg-types tagged-num)
1615 (:results (digit :scs (unsigned-reg)
1616 :load-if (not (and (sc-is fixnum control-stack)
1617 (sc-is digit unsigned-stack)
1618 (location= fixnum digit)))))
1619 (:result-types unsigned-num)
1622 (inst sar digit 3)))
1624 (define-vop (bignum-floor)
1625 (:translate sb!bignum:%floor)
1626 (:policy :fast-safe)
1627 (:args (div-high :scs (unsigned-reg) :target edx)
1628 (div-low :scs (unsigned-reg) :target eax)
1629 (divisor :scs (unsigned-reg unsigned-stack)))
1630 (:arg-types unsigned-num unsigned-num unsigned-num)
1631 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
1632 :to (:result 0) :target quo) eax)
1633 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
1634 :to (:result 1) :target rem) edx)
1635 (:results (quo :scs (unsigned-reg))
1636 (rem :scs (unsigned-reg)))
1637 (:result-types unsigned-num unsigned-num)
1641 (inst div eax divisor)
1645 (define-vop (signify-digit)
1646 (:translate sb!bignum:%fixnum-digit-with-correct-sign)
1647 (:policy :fast-safe)
1648 (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
1649 (:arg-types unsigned-num)
1650 (:results (res :scs (any-reg signed-reg)
1651 :load-if (not (and (sc-is digit unsigned-stack)
1652 (sc-is res control-stack signed-stack)
1653 (location= digit res)))))
1654 (:result-types signed-num)
1657 (when (sc-is res any-reg control-stack)
1660 (define-vop (digit-ashr)
1661 (:translate sb!bignum:%ashr)
1662 (:policy :fast-safe)
1663 (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
1664 (count :scs (unsigned-reg) :target ecx))
1665 (:arg-types unsigned-num positive-fixnum)
1666 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
1667 (:results (result :scs (unsigned-reg) :from (:argument 0)
1668 :load-if (not (and (sc-is result unsigned-stack)
1669 (location= digit result)))))
1670 (:result-types unsigned-num)
1674 (inst sar result :cl)))
1676 (define-vop (digit-ashr/c)
1677 (:translate sb!bignum:%ashr)
1678 (:policy :fast-safe)
1679 (:args (digit :scs (unsigned-reg unsigned-stack) :target result))
1680 (:arg-types unsigned-num (:constant (integer 0 63)))
1682 (:results (result :scs (unsigned-reg) :from (:argument 0)
1683 :load-if (not (and (sc-is result unsigned-stack)
1684 (location= digit result)))))
1685 (:result-types unsigned-num)
1688 (inst sar result count)))
1690 (define-vop (digit-lshr digit-ashr)
1691 (:translate sb!bignum:%digit-logical-shift-right)
1695 (inst shr result :cl)))
1697 (define-vop (digit-ashl digit-ashr)
1698 (:translate sb!bignum:%ashl)
1702 (inst shl result :cl)))
1704 ;;;; static functions
1706 (define-static-fun two-arg-/ (x y) :translate /)
1708 (define-static-fun two-arg-gcd (x y) :translate gcd)
1709 (define-static-fun two-arg-lcm (x y) :translate lcm)
1711 (define-static-fun two-arg-and (x y) :translate logand)
1712 (define-static-fun two-arg-ior (x y) :translate logior)
1713 (define-static-fun two-arg-xor (x y) :translate logxor)
1718 (defun *-transformer (y)
1720 ((= y (ash 1 (integer-length y)))
1721 ;; there's a generic transform for y = 2^k
1722 (give-up-ir1-transform))
1723 ((member y '(3 5 9))
1724 ;; we can do these multiplications directly using LEA
1725 `(%lea x x ,(1- y) 0))
1727 ;; A normal 64-bit multiplication takes 4 cycles on Athlon 64/Opteron.
1728 ;; Optimizing multiplications (other than the above cases) to
1729 ;; shifts/adds/leas gives a maximum improvement of 1 cycle, but requires
1730 ;; quite a lot of hairy code.
1731 (give-up-ir1-transform))))
1733 (deftransform * ((x y)
1734 ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1736 "recode as leas, shifts and adds"
1737 (let ((y (lvar-value y)))
1739 (deftransform sb!vm::*-mod64
1740 ((x y) ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1742 "recode as leas, shifts and adds"
1743 (let ((y (lvar-value y)))
1746 (deftransform * ((x y)
1747 ((signed-byte 61) (constant-arg (unsigned-byte 64)))
1749 "recode as leas, shifts and adds"
1750 (let ((y (lvar-value y)))
1752 (deftransform sb!vm::*-smod61
1753 ((x y) ((signed-byte 61) (constant-arg (unsigned-byte 64)))
1755 "recode as leas, shifts and adds"
1756 (let ((y (lvar-value y)))