1 ;;;; the VM definition of arithmetic VOPs for the x86
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 32) 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 32) 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 32) arithmetic"))
111 (define-vop (fast-fixnum-binop-c fast-safe-arith-op)
112 (:args (x :target r :scs (any-reg control-stack)))
114 (:arg-types tagged-num (:constant (signed-byte 29)))
115 (:results (r :scs (any-reg)
116 :load-if (not (location= x r))))
117 (:result-types tagged-num)
118 (:note "inline fixnum arithmetic"))
120 ;; 31 not 64 because it's hard work loading 64 bit constants, and since
121 ;; sign-extension of immediates causes problems with 32.
122 (define-vop (fast-unsigned-binop-c fast-safe-arith-op)
123 (:args (x :target r :scs (unsigned-reg unsigned-stack)))
125 (:arg-types unsigned-num (:constant (unsigned-byte 31)))
126 (:results (r :scs (unsigned-reg)
127 :load-if (not (location= x r))))
128 (:result-types unsigned-num)
129 (:note "inline (unsigned-byte 32) arithmetic"))
131 ;; 32 not 64 because it's hard work loading 64 bit constants
132 (define-vop (fast-signed-binop-c fast-safe-arith-op)
133 (:args (x :target r :scs (signed-reg signed-stack)))
135 (:arg-types signed-num (:constant (signed-byte 32)))
136 (:results (r :scs (signed-reg)
137 :load-if (not (location= x r))))
138 (:result-types signed-num)
139 (:note "inline (signed-byte 32) arithmetic"))
141 (macrolet ((define-binop (translate untagged-penalty op)
143 (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
145 (:translate ,translate)
149 (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
151 (:translate ,translate)
154 (inst ,op r (fixnumize y))))
155 (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
157 (:translate ,translate)
158 (:generator ,(1+ untagged-penalty)
161 (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
163 (:translate ,translate)
164 (:generator ,untagged-penalty
167 (define-vop (,(symbolicate "FAST-"
169 "/UNSIGNED=>UNSIGNED")
171 (:translate ,translate)
172 (:generator ,(1+ untagged-penalty)
175 (define-vop (,(symbolicate 'fast-
177 '-c/unsigned=>unsigned)
178 fast-unsigned-binop-c)
179 (:translate ,translate)
180 (:generator ,untagged-penalty
184 ;;(define-binop + 4 add)
185 (define-binop - 4 sub)
186 (define-binop logand 2 and)
187 (define-binop logior 2 or)
188 (define-binop logxor 2 xor))
190 ;;; Special handling of add on the x86; can use lea to avoid a
191 ;;; register load, otherwise it uses add.
192 (define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op)
194 (:args (x :scs (any-reg) :target r
195 :load-if (not (and (sc-is x control-stack)
197 (sc-is r control-stack)
199 (y :scs (any-reg control-stack)))
200 (:arg-types tagged-num tagged-num)
201 (:results (r :scs (any-reg) :from (:argument 0)
202 :load-if (not (and (sc-is x control-stack)
204 (sc-is r control-stack)
206 (:result-types tagged-num)
207 (:note "inline fixnum arithmetic")
209 (cond ((and (sc-is x any-reg) (sc-is y any-reg) (sc-is r any-reg)
210 (not (location= x r)))
211 (inst lea r (make-ea :qword :base x :index y :scale 1)))
216 (define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op)
218 (:args (x :target r :scs (any-reg control-stack)))
220 (:arg-types tagged-num (:constant (signed-byte 29)))
221 (:results (r :scs (any-reg)
222 :load-if (not (location= x r))))
223 (:result-types tagged-num)
224 (:note "inline fixnum arithmetic")
226 (cond ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r)))
227 (inst lea r (make-ea :qword :base x :disp (fixnumize y))))
230 (inst add r (fixnumize y))))))
232 (define-vop (fast-+/signed=>signed fast-safe-arith-op)
234 (:args (x :scs (signed-reg) :target r
235 :load-if (not (and (sc-is x signed-stack)
237 (sc-is r signed-stack)
239 (y :scs (signed-reg signed-stack)))
240 (:arg-types signed-num signed-num)
241 (:results (r :scs (signed-reg) :from (:argument 0)
242 :load-if (not (and (sc-is x signed-stack)
245 (:result-types signed-num)
246 (:note "inline (signed-byte 32) arithmetic")
248 (cond ((and (sc-is x signed-reg) (sc-is y signed-reg) (sc-is r signed-reg)
249 (not (location= x r)))
250 (inst lea r (make-ea :qword :base x :index y :scale 1)))
256 ;;;; Special logand cases: (logand signed unsigned) => unsigned
258 (define-vop (fast-logand/signed-unsigned=>unsigned
259 fast-logand/unsigned=>unsigned)
260 (:args (x :target r :scs (signed-reg)
261 :load-if (not (and (sc-is x signed-stack)
262 (sc-is y unsigned-reg)
263 (sc-is r unsigned-stack)
265 (y :scs (unsigned-reg unsigned-stack)))
266 (:arg-types signed-num unsigned-num))
268 (define-vop (fast-logand-c/signed-unsigned=>unsigned
269 fast-logand-c/unsigned=>unsigned)
270 (:args (x :target r :scs (signed-reg signed-stack)))
271 (:arg-types signed-num (:constant (unsigned-byte 32))))
273 (define-vop (fast-logand/unsigned-signed=>unsigned
274 fast-logand/unsigned=>unsigned)
275 (:args (x :target r :scs (unsigned-reg)
276 :load-if (not (and (sc-is x unsigned-stack)
278 (sc-is r unsigned-stack)
280 (y :scs (signed-reg signed-stack)))
281 (:arg-types unsigned-num signed-num))
284 (define-vop (fast-+-c/signed=>signed fast-safe-arith-op)
286 (:args (x :target r :scs (signed-reg signed-stack)))
288 (:arg-types signed-num (:constant (signed-byte 32)))
289 (:results (r :scs (signed-reg)
290 :load-if (not (location= x r))))
291 (:result-types signed-num)
292 (:note "inline (signed-byte 32) arithmetic")
294 (cond ((and (sc-is x signed-reg) (sc-is r signed-reg)
295 (not (location= x r)))
296 (inst lea r (make-ea :qword :base x :disp y)))
303 (define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op)
305 (:args (x :scs (unsigned-reg) :target r
306 :load-if (not (and (sc-is x unsigned-stack)
307 (sc-is y unsigned-reg)
308 (sc-is r unsigned-stack)
310 (y :scs (unsigned-reg unsigned-stack)))
311 (:arg-types unsigned-num unsigned-num)
312 (:results (r :scs (unsigned-reg) :from (:argument 0)
313 :load-if (not (and (sc-is x unsigned-stack)
314 (sc-is y unsigned-reg)
315 (sc-is r unsigned-stack)
317 (:result-types unsigned-num)
318 (:note "inline (unsigned-byte 32) arithmetic")
320 (cond ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg)
321 (sc-is r unsigned-reg) (not (location= x r)))
322 (inst lea r (make-ea :qword :base x :index y :scale 1)))
327 (define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op)
329 (:args (x :target r :scs (unsigned-reg unsigned-stack)))
331 (:arg-types unsigned-num (:constant (unsigned-byte 32)))
332 (:results (r :scs (unsigned-reg)
333 :load-if (not (location= x r))))
334 (:result-types unsigned-num)
335 (:note "inline (unsigned-byte 32) arithmetic")
337 (cond ((and (sc-is x unsigned-reg) (sc-is r unsigned-reg)
338 (not (location= x r)))
339 (inst lea r (make-ea :qword :base x :disp y)))
346 ;;;; multiplication and division
348 (define-vop (fast-*/fixnum=>fixnum fast-safe-arith-op)
350 ;; We need different loading characteristics.
351 (:args (x :scs (any-reg) :target r)
352 (y :scs (any-reg control-stack)))
353 (:arg-types tagged-num tagged-num)
354 (:results (r :scs (any-reg) :from (:argument 0)))
355 (:result-types tagged-num)
356 (:note "inline fixnum arithmetic")
362 (define-vop (fast-*-c/fixnum=>fixnum fast-safe-arith-op)
364 ;; We need different loading characteristics.
365 (:args (x :scs (any-reg control-stack)))
367 (:arg-types tagged-num (:constant (signed-byte 29)))
368 (:results (r :scs (any-reg)))
369 (:result-types tagged-num)
370 (:note "inline fixnum arithmetic")
374 (define-vop (fast-*/signed=>signed fast-safe-arith-op)
376 ;; We need different loading characteristics.
377 (:args (x :scs (signed-reg) :target r)
378 (y :scs (signed-reg signed-stack)))
379 (:arg-types signed-num signed-num)
380 (:results (r :scs (signed-reg) :from (:argument 0)))
381 (:result-types signed-num)
382 (:note "inline (signed-byte 32) arithmetic")
387 (define-vop (fast-*-c/signed=>signed fast-safe-arith-op)
389 ;; We need different loading characteristics.
390 (:args (x :scs (signed-reg signed-stack)))
392 (:arg-types signed-num (:constant (signed-byte 32)))
393 (:results (r :scs (signed-reg)))
394 (:result-types signed-num)
395 (:note "inline (signed-byte 32) arithmetic")
399 (define-vop (fast-*/unsigned=>unsigned fast-safe-arith-op)
401 (:args (x :scs (unsigned-reg) :target eax)
402 (y :scs (unsigned-reg unsigned-stack)))
403 (:arg-types unsigned-num unsigned-num)
404 (:temporary (:sc unsigned-reg :offset eax-offset :target result
405 :from (:argument 0) :to :result) eax)
406 (:temporary (:sc unsigned-reg :offset edx-offset
407 :from :eval :to :result) edx)
409 (:results (result :scs (unsigned-reg)))
410 (:result-types unsigned-num)
411 (:note "inline (unsigned-byte 32) arithmetic")
413 (:save-p :compute-only)
420 (define-vop (fast-truncate/fixnum=>fixnum fast-safe-arith-op)
421 (:translate truncate)
422 (:args (x :scs (any-reg) :target eax)
423 (y :scs (any-reg control-stack)))
424 (:arg-types tagged-num tagged-num)
425 (:temporary (:sc signed-reg :offset eax-offset :target quo
426 :from (:argument 0) :to (:result 0)) eax)
427 (:temporary (:sc unsigned-reg :offset edx-offset :target rem
428 :from (:argument 0) :to (:result 1)) edx)
429 (:results (quo :scs (any-reg))
430 (rem :scs (any-reg)))
431 (:result-types tagged-num tagged-num)
432 (:note "inline fixnum arithmetic")
434 (:save-p :compute-only)
436 (let ((zero (generate-error-code vop division-by-zero-error x y)))
437 (if (sc-is y any-reg)
438 (inst test y y) ; smaller instruction
444 (if (location= quo eax)
446 (inst lea quo (make-ea :qword :index eax :scale 8)))
449 (define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
450 (:translate truncate)
451 (:args (x :scs (any-reg) :target eax))
453 (:arg-types tagged-num (:constant (signed-byte 29)))
454 (:temporary (:sc signed-reg :offset eax-offset :target quo
455 :from :argument :to (:result 0)) eax)
456 (:temporary (:sc any-reg :offset edx-offset :target rem
457 :from :eval :to (:result 1)) edx)
458 (:temporary (:sc any-reg :from :eval :to :result) y-arg)
459 (:results (quo :scs (any-reg))
460 (rem :scs (any-reg)))
461 (:result-types tagged-num tagged-num)
462 (:note "inline fixnum arithmetic")
464 (:save-p :compute-only)
468 (inst mov y-arg (fixnumize y))
469 (inst idiv eax y-arg)
470 (if (location= quo eax)
472 (inst lea quo (make-ea :qword :index eax :scale 8)))
475 (define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
476 (:translate truncate)
477 (:args (x :scs (unsigned-reg) :target eax)
478 (y :scs (unsigned-reg signed-stack)))
479 (:arg-types unsigned-num unsigned-num)
480 (:temporary (:sc unsigned-reg :offset eax-offset :target quo
481 :from (:argument 0) :to (:result 0)) eax)
482 (:temporary (:sc unsigned-reg :offset edx-offset :target rem
483 :from (:argument 0) :to (:result 1)) edx)
484 (:results (quo :scs (unsigned-reg))
485 (rem :scs (unsigned-reg)))
486 (:result-types unsigned-num unsigned-num)
487 (:note "inline (unsigned-byte 32) arithmetic")
489 (:save-p :compute-only)
491 (let ((zero (generate-error-code vop division-by-zero-error x y)))
492 (if (sc-is y unsigned-reg)
493 (inst test y y) ; smaller instruction
502 (define-vop (fast-truncate-c/unsigned=>unsigned fast-safe-arith-op)
503 (:translate truncate)
504 (:args (x :scs (unsigned-reg) :target eax))
506 (:arg-types unsigned-num (:constant (unsigned-byte 32)))
507 (:temporary (:sc unsigned-reg :offset eax-offset :target quo
508 :from :argument :to (:result 0)) eax)
509 (:temporary (:sc unsigned-reg :offset edx-offset :target rem
510 :from :eval :to (:result 1)) edx)
511 (:temporary (:sc unsigned-reg :from :eval :to :result) y-arg)
512 (:results (quo :scs (unsigned-reg))
513 (rem :scs (unsigned-reg)))
514 (:result-types unsigned-num unsigned-num)
515 (:note "inline (unsigned-byte 32) arithmetic")
517 (:save-p :compute-only)
526 (define-vop (fast-truncate/signed=>signed fast-safe-arith-op)
527 (:translate truncate)
528 (:args (x :scs (signed-reg) :target eax)
529 (y :scs (signed-reg signed-stack)))
530 (:arg-types signed-num signed-num)
531 (:temporary (:sc signed-reg :offset eax-offset :target quo
532 :from (:argument 0) :to (:result 0)) eax)
533 (:temporary (:sc signed-reg :offset edx-offset :target rem
534 :from (:argument 0) :to (:result 1)) edx)
535 (:results (quo :scs (signed-reg))
536 (rem :scs (signed-reg)))
537 (:result-types signed-num signed-num)
538 (:note "inline (signed-byte 32) arithmetic")
540 (:save-p :compute-only)
542 (let ((zero (generate-error-code vop division-by-zero-error x y)))
543 (if (sc-is y signed-reg)
544 (inst test y y) ; smaller instruction
553 (define-vop (fast-truncate-c/signed=>signed fast-safe-arith-op)
554 (:translate truncate)
555 (:args (x :scs (signed-reg) :target eax))
557 (:arg-types signed-num (:constant (signed-byte 32)))
558 (:temporary (:sc signed-reg :offset eax-offset :target quo
559 :from :argument :to (:result 0)) eax)
560 (:temporary (:sc signed-reg :offset edx-offset :target rem
561 :from :eval :to (:result 1)) edx)
562 (:temporary (:sc signed-reg :from :eval :to :result) y-arg)
563 (:results (quo :scs (signed-reg))
564 (rem :scs (signed-reg)))
565 (:result-types signed-num signed-num)
566 (:note "inline (signed-byte 32) arithmetic")
568 (:save-p :compute-only)
573 (inst idiv eax y-arg)
580 (define-vop (fast-ash-c/fixnum=>fixnum)
583 (:args (number :scs (any-reg) :target result
584 :load-if (not (and (sc-is number any-reg control-stack)
585 (sc-is result any-reg control-stack)
586 (location= number result)))))
588 (:arg-types tagged-num (:constant integer))
589 (:results (result :scs (any-reg)
590 :load-if (not (and (sc-is number control-stack)
591 (sc-is result control-stack)
592 (location= number result)))))
593 (:result-types tagged-num)
596 (cond ((and (= amount 1) (not (location= number result)))
597 (inst lea result (make-ea :qword :index number :scale 2)))
598 ((and (= amount 2) (not (location= number result)))
599 (inst lea result (make-ea :qword :index number :scale 4)))
600 ((and (= amount 3) (not (location= number result)))
601 (inst lea result (make-ea :qword :index number :scale 8)))
604 (cond ((plusp amount)
605 ;; We don't have to worry about overflow because of the
606 ;; result type restriction.
607 (inst shl result amount))
609 ;; Since the shift instructions take the shift amount
610 ;; modulo 64 we must special case amounts of 64 and more.
611 ;; Because fixnums have only 61 bits, the result is 0 or
612 ;; -1 for all amounts of 60 or more, so use this as the
614 (inst sar result (min (- n-word-bits n-fixnum-tag-bits 1)
616 (inst and result (lognot fixnum-tag-mask))))))))
618 (define-vop (fast-ash-left/fixnum=>fixnum)
620 (:args (number :scs (any-reg) :target result
621 :load-if (not (and (sc-is number control-stack)
622 (sc-is result control-stack)
623 (location= number result))))
624 (amount :scs (unsigned-reg) :target ecx))
625 (:arg-types tagged-num positive-fixnum)
626 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
627 (:results (result :scs (any-reg) :from (:argument 0)
628 :load-if (not (and (sc-is number control-stack)
629 (sc-is result control-stack)
630 (location= number result)))))
631 (:result-types tagged-num)
637 ;; The result-type ensures us that this shift will not overflow.
638 (inst shl result :cl)))
640 (define-vop (fast-ash-c/signed=>signed)
643 (:args (number :scs (signed-reg) :target result
644 :load-if (not (and (sc-is number signed-stack)
645 (sc-is result signed-stack)
646 (location= number result)))))
648 (:arg-types signed-num (:constant integer))
649 (:results (result :scs (signed-reg)
650 :load-if (not (and (sc-is number signed-stack)
651 (sc-is result signed-stack)
652 (location= number result)))))
653 (:result-types signed-num)
656 (cond ((and (= amount 1) (not (location= number result)))
657 (inst lea result (make-ea :qword :index number :scale 2)))
658 ((and (= amount 2) (not (location= number result)))
659 (inst lea result (make-ea :qword :index number :scale 4)))
660 ((and (= amount 3) (not (location= number result)))
661 (inst lea result (make-ea :qword :index number :scale 8)))
664 (cond ((plusp amount) (inst shl result amount))
665 (t (inst sar result (min 63 (- amount)))))))))
667 (define-vop (fast-ash-c/unsigned=>unsigned)
670 (:args (number :scs (unsigned-reg) :target result
671 :load-if (not (and (sc-is number unsigned-stack)
672 (sc-is result unsigned-stack)
673 (location= number result)))))
675 (:arg-types unsigned-num (:constant integer))
676 (:results (result :scs (unsigned-reg)
677 :load-if (not (and (sc-is number unsigned-stack)
678 (sc-is result unsigned-stack)
679 (location= number result)))))
680 (:result-types unsigned-num)
683 (cond ((and (= amount 1) (not (location= number result)))
684 (inst lea result (make-ea :qword :index number :scale 2)))
685 ((and (= amount 2) (not (location= number result)))
686 (inst lea result (make-ea :qword :index number :scale 4)))
687 ((and (= amount 3) (not (location= number result)))
688 (inst lea result (make-ea :qword :index number :scale 8)))
691 (cond ((< -64 amount 64) ;; XXXX
692 ;; this code is used both in ASH and ASH-MOD32, so
695 (inst shl result amount)
696 (inst shr result (- amount))))
697 (t (if (sc-is result unsigned-reg)
698 (inst xor result result)
699 (inst mov result 0))))))))
701 (define-vop (fast-ash-left/signed=>signed)
703 (:args (number :scs (signed-reg) :target result
704 :load-if (not (and (sc-is number signed-stack)
705 (sc-is result signed-stack)
706 (location= number result))))
707 (amount :scs (unsigned-reg) :target ecx))
708 (:arg-types signed-num positive-fixnum)
709 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
710 (:results (result :scs (signed-reg) :from (:argument 0)
711 :load-if (not (and (sc-is number signed-stack)
712 (sc-is result signed-stack)
713 (location= number result)))))
714 (:result-types signed-num)
720 (inst shl result :cl)))
722 (define-vop (fast-ash-left/unsigned=>unsigned)
724 (:args (number :scs (unsigned-reg) :target result
725 :load-if (not (and (sc-is number unsigned-stack)
726 (sc-is result unsigned-stack)
727 (location= number result))))
728 (amount :scs (unsigned-reg) :target ecx))
729 (:arg-types unsigned-num positive-fixnum)
730 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
731 (:results (result :scs (unsigned-reg) :from (:argument 0)
732 :load-if (not (and (sc-is number unsigned-stack)
733 (sc-is result unsigned-stack)
734 (location= number result)))))
735 (:result-types unsigned-num)
741 (inst shl result :cl)))
743 (define-vop (fast-ash/signed=>signed)
746 (:args (number :scs (signed-reg) :target result)
747 (amount :scs (signed-reg) :target ecx))
748 (:arg-types signed-num signed-num)
749 (:results (result :scs (signed-reg) :from (:argument 0)))
750 (:result-types signed-num)
751 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
757 (inst jmp :ns positive)
763 (inst sar result :cl)
767 ;; The result-type ensures us that this shift will not overflow.
768 (inst shl result :cl)
772 (define-vop (fast-ash/unsigned=>unsigned)
775 (:args (number :scs (unsigned-reg) :target result)
776 (amount :scs (signed-reg) :target ecx))
777 (:arg-types unsigned-num signed-num)
778 (:results (result :scs (unsigned-reg) :from (:argument 0)))
779 (:result-types unsigned-num)
780 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
786 (inst jmp :ns positive)
790 (inst xor result result)
793 (inst shr result :cl)
797 ;; The result-type ensures us that this shift will not overflow.
798 (inst shl result :cl)
804 (defknown %lea (integer integer (member 1 2 4 8 16) (signed-byte 64))
806 (foldable flushable movable))
808 (defoptimizer (%lea derive-type) ((base index scale disp))
809 (when (and (constant-lvar-p scale)
810 (constant-lvar-p disp))
811 (let ((scale (lvar-value scale))
812 (disp (lvar-value disp))
813 (base-type (lvar-type base))
814 (index-type (lvar-type index)))
815 (when (and (numeric-type-p base-type)
816 (numeric-type-p index-type))
817 (let ((base-lo (numeric-type-low base-type))
818 (base-hi (numeric-type-high base-type))
819 (index-lo (numeric-type-low index-type))
820 (index-hi (numeric-type-high index-type)))
821 (make-numeric-type :class 'integer
823 :low (when (and base-lo index-lo)
824 (+ base-lo (* index-lo scale) disp))
825 :high (when (and base-hi index-hi)
826 (+ base-hi (* index-hi scale) disp))))))))
828 (defun %lea (base index scale disp)
829 (+ base (* index scale) disp))
833 (define-vop (%lea/unsigned=>unsigned)
836 (:args (base :scs (unsigned-reg))
837 (index :scs (unsigned-reg)))
839 (:arg-types unsigned-num unsigned-num
840 (:constant (member 1 2 4 8))
841 (:constant (signed-byte 64)))
842 (:results (r :scs (unsigned-reg)))
843 (:result-types unsigned-num)
845 (inst lea r (make-ea :qword :base base :index index
846 :scale scale :disp disp))))
848 (define-vop (%lea/signed=>signed)
851 (:args (base :scs (signed-reg))
852 (index :scs (signed-reg)))
854 (:arg-types signed-num signed-num
855 (:constant (member 1 2 4 8))
856 (:constant (signed-byte 64)))
857 (:results (r :scs (signed-reg)))
858 (:result-types signed-num)
860 (inst lea r (make-ea :qword :base base :index index
861 :scale scale :disp disp))))
863 (define-vop (%lea/fixnum=>fixnum)
866 (:args (base :scs (any-reg))
867 (index :scs (any-reg)))
869 (:arg-types tagged-num tagged-num
870 (:constant (member 1 2 4 8))
871 (:constant (signed-byte 64)))
872 (:results (r :scs (any-reg)))
873 (:result-types tagged-num)
875 (inst lea r (make-ea :qword :base base :index index
876 :scale scale :disp disp))))
878 ;;; FIXME: before making knowledge of this too public, it needs to be
879 ;;; fixed so that it's actually _faster_ than the non-CMOV version; at
880 ;;; least on my Celeron-XXX laptop, this version is marginally slower
881 ;;; than the above version with branches. -- CSR, 2003-09-04
882 (define-vop (fast-cmov-ash/unsigned=>unsigned)
885 (:args (number :scs (unsigned-reg) :target result)
886 (amount :scs (signed-reg) :target ecx))
887 (:arg-types unsigned-num signed-num)
888 (:results (result :scs (unsigned-reg) :from (:argument 0)))
889 (:result-types unsigned-num)
890 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
891 (:temporary (:sc any-reg :from (:eval 0) :to (:eval 1)) zero)
893 (:guard (member :cmov *backend-subfeatures*))
898 (inst jmp :ns positive)
901 (inst shr result :cl)
903 (inst cmov :nbe result zero)
907 ;; The result-type ensures us that this shift will not overflow.
908 (inst shl result :cl)
912 (define-vop (signed-byte-64-len)
913 (:translate integer-length)
914 (:note "inline (signed-byte 32) integer-length")
916 (:args (arg :scs (signed-reg) :target res))
917 (:arg-types signed-num)
918 (:results (res :scs (unsigned-reg)))
919 (:result-types unsigned-num)
934 (define-vop (unsigned-byte-64-len)
935 (:translate integer-length)
936 (:note "inline (unsigned-byte 32) integer-length")
938 (:args (arg :scs (unsigned-reg)))
939 (:arg-types unsigned-num)
940 (:results (res :scs (unsigned-reg)))
941 (:result-types unsigned-num)
952 (define-vop (unsigned-byte-64-count)
953 (:translate logcount)
954 (:note "inline (unsigned-byte 64) logcount")
956 (:args (arg :scs (unsigned-reg)))
957 (:arg-types unsigned-num)
958 (:results (result :scs (unsigned-reg)))
959 (:result-types positive-fixnum)
960 (:temporary (:sc unsigned-reg :from (:argument 0)) temp)
961 (:temporary (:sc unsigned-reg :from (:argument 0)) t1)
966 (inst mov temp result)
968 (inst and result #x55555555) ; note these masks will restrict the
969 (inst and temp #x55555555) ; count to the lower half of arg
970 (inst add result temp)
972 (inst mov temp result)
974 (inst and result #x33333333)
975 (inst and temp #x33333333)
976 (inst add result temp)
978 (inst mov temp result)
980 (inst and result #x0f0f0f0f)
981 (inst and temp #x0f0f0f0f)
982 (inst add result temp)
984 (inst mov temp result)
986 (inst and result #x00ff00ff)
987 (inst and temp #x00ff00ff)
988 (inst add result temp)
990 (inst mov temp result)
992 (inst and result #x0000ffff)
993 (inst and temp #x0000ffff)
994 (inst add result temp)
996 ;;; now do the upper half
1001 (inst and t1 #x55555555)
1002 (inst and temp #x55555555)
1007 (inst and t1 #x33333333)
1008 (inst and temp #x33333333)
1013 (inst and t1 #x0f0f0f0f)
1014 (inst and temp #x0f0f0f0f)
1019 (inst and t1 #x00ff00ff)
1020 (inst and temp #x00ff00ff)
1025 (inst and t1 #x0000ffff)
1026 (inst and temp #x0000ffff)
1028 (inst add result t1)))
1032 ;;;; binary conditional VOPs
1034 (define-vop (fast-conditional)
1036 (:info target not-p)
1039 (:policy :fast-safe))
1041 ;;; constant variants are declared for 32 bits not 64 bits, because
1042 ;;; loading a 64 bit constant is silly
1044 (define-vop (fast-conditional/fixnum fast-conditional)
1045 (:args (x :scs (any-reg)
1046 :load-if (not (and (sc-is x control-stack)
1047 (sc-is y any-reg))))
1048 (y :scs (any-reg control-stack)))
1049 (:arg-types tagged-num tagged-num)
1050 (:note "inline fixnum comparison"))
1052 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
1053 (:args (x :scs (any-reg control-stack)))
1054 (:arg-types tagged-num (:constant (signed-byte 29)))
1055 (:info target not-p y))
1057 (define-vop (fast-conditional/signed fast-conditional)
1058 (:args (x :scs (signed-reg)
1059 :load-if (not (and (sc-is x signed-stack)
1060 (sc-is y signed-reg))))
1061 (y :scs (signed-reg signed-stack)))
1062 (:arg-types signed-num signed-num)
1063 (:note "inline (signed-byte 32) comparison"))
1065 (define-vop (fast-conditional-c/signed fast-conditional/signed)
1066 (:args (x :scs (signed-reg signed-stack)))
1067 (:arg-types signed-num (:constant (signed-byte 31)))
1068 (:info target not-p y))
1070 (define-vop (fast-conditional/unsigned fast-conditional)
1071 (:args (x :scs (unsigned-reg)
1072 :load-if (not (and (sc-is x unsigned-stack)
1073 (sc-is y unsigned-reg))))
1074 (y :scs (unsigned-reg unsigned-stack)))
1075 (:arg-types unsigned-num unsigned-num)
1076 (:note "inline (unsigned-byte 32) comparison"))
1078 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
1079 (:args (x :scs (unsigned-reg unsigned-stack)))
1080 (:arg-types unsigned-num (:constant (unsigned-byte 31)))
1081 (:info target not-p y))
1083 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
1086 (lambda (suffix cost signed)
1087 `(define-vop (;; FIXME: These could be done more
1088 ;; cleanly with SYMBOLICATE.
1089 ,(intern (format nil "~:@(FAST-IF-~A~A~)"
1092 (format nil "~:@(FAST-CONDITIONAL~A~)"
1097 ,(if (eq suffix '-c/fixnum)
1108 '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
1109 ; '(/fixnum /signed /unsigned)
1111 '(t t t t nil nil)))))
1113 (define-conditional-vop < :l :b :ge :ae)
1114 (define-conditional-vop > :g :a :le :be))
1116 (define-vop (fast-if-eql/signed fast-conditional/signed)
1120 (inst jmp (if not-p :ne :e) target)))
1122 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
1125 (cond ((and (sc-is x signed-reg) (zerop y))
1126 (inst test x x)) ; smaller instruction
1129 (inst jmp (if not-p :ne :e) target)))
1131 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
1135 (inst jmp (if not-p :ne :e) target)))
1137 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
1140 (cond ((and (sc-is x unsigned-reg) (zerop y))
1141 (inst test x x)) ; smaller instruction
1144 (inst jmp (if not-p :ne :e) target)))
1146 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
1149 ;;; These versions specify a fixnum restriction on their first arg. We have
1150 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
1151 ;;; the first arg and a higher cost. The reason for doing this is to prevent
1152 ;;; fixnum specific operations from being used on word integers, spuriously
1153 ;;; consing the argument.
1155 (define-vop (fast-eql/fixnum fast-conditional)
1156 (:args (x :scs (any-reg)
1157 :load-if (not (and (sc-is x control-stack)
1158 (sc-is y any-reg))))
1159 (y :scs (any-reg control-stack)))
1160 (:arg-types tagged-num tagged-num)
1161 (:note "inline fixnum comparison")
1165 (inst jmp (if not-p :ne :e) target)))
1166 (define-vop (generic-eql/fixnum fast-eql/fixnum)
1167 (:args (x :scs (any-reg descriptor-reg)
1168 :load-if (not (and (sc-is x control-stack)
1169 (sc-is y any-reg))))
1170 (y :scs (any-reg control-stack)))
1171 (:arg-types * tagged-num)
1175 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
1176 (:args (x :scs (any-reg control-stack)))
1177 (:arg-types tagged-num (:constant (signed-byte 29)))
1178 (:info target not-p y)
1181 (cond ((and (sc-is x any-reg) (zerop y))
1182 (inst test x x)) ; smaller instruction
1184 (inst cmp x (fixnumize y))))
1185 (inst jmp (if not-p :ne :e) target)))
1187 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
1188 (:args (x :scs (any-reg descriptor-reg control-stack)))
1189 (:arg-types * (:constant (signed-byte 29)))
1192 ;;;; 32-bit logical operations
1194 (define-vop (merge-bits)
1195 (:translate merge-bits)
1196 (:args (shift :scs (signed-reg unsigned-reg) :target ecx)
1197 (prev :scs (unsigned-reg) :target result)
1198 (next :scs (unsigned-reg)))
1199 (:arg-types tagged-num unsigned-num unsigned-num)
1200 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 0)) ecx)
1201 (:results (result :scs (unsigned-reg) :from (:argument 1)))
1202 (:result-types unsigned-num)
1203 (:policy :fast-safe)
1207 (inst shrd result next :cl)))
1209 ;;; Only the lower 6 bits of the shift amount are significant.
1210 (define-vop (shift-towards-someplace)
1211 (:policy :fast-safe)
1212 (:args (num :scs (unsigned-reg) :target r)
1213 (amount :scs (signed-reg) :target ecx))
1214 (:arg-types unsigned-num tagged-num)
1215 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
1216 (:results (r :scs (unsigned-reg) :from (:argument 0)))
1217 (:result-types unsigned-num))
1219 (define-vop (shift-towards-start shift-towards-someplace)
1220 (:translate shift-towards-start)
1221 (:note "SHIFT-TOWARDS-START")
1227 (define-vop (shift-towards-end shift-towards-someplace)
1228 (:translate shift-towards-end)
1229 (:note "SHIFT-TOWARDS-END")
1235 ;;;; Modular functions
1237 (macrolet ((def (name -c-p)
1238 (let ((fun64 (intern (format nil "~S-MOD64" name)))
1239 (vopu (intern (format nil "FAST-~S/UNSIGNED=>UNSIGNED" name)))
1240 (vopcu (intern (format nil "FAST-~S-C/UNSIGNED=>UNSIGNED" name)))
1241 (vopf (intern (format nil "FAST-~S/FIXNUM=>FIXNUM" name)))
1242 (vopcf (intern (format nil "FAST-~S-C/FIXNUM=>FIXNUM" name)))
1243 (vop64u (intern (format nil "FAST-~S-MOD64/UNSIGNED=>UNSIGNED" name)))
1244 (vop64f (intern (format nil "FAST-~S-MOD64/FIXNUM=>FIXNUM" name)))
1245 (vop64cu (intern (format nil "FAST-~S-MOD64-C/UNSIGNED=>UNSIGNED" name)))
1246 (vop64cf (intern (format nil "FAST-~S-MOD64-C/FIXNUM=>FIXNUM" name)))
1247 (sfun61 (intern (format nil "~S-SMOD61" name)))
1248 (svop61f (intern (format nil "FAST-~S-SMOD61/FIXNUM=>FIXNUM" name)))
1249 (svop61cf (intern (format nil "FAST-~S-SMOD61-C/FIXNUM=>FIXNUM" name))))
1251 (define-modular-fun ,fun64 (x y) ,name :unsigned 64)
1252 (define-modular-fun ,sfun61 (x y) ,name :signed 61)
1253 (define-vop (,vop64u ,vopu) (:translate ,fun64))
1254 (define-vop (,vop64f ,vopf) (:translate ,fun64))
1255 (define-vop (,svop61f ,vopf) (:translate ,sfun61))
1257 `((define-vop (,vop64cu ,vopcu) (:translate ,fun64))
1258 (define-vop (,svop61cf ,vopcf) (:translate ,sfun61))))))))
1261 ;; (no -C variant as x86 MUL instruction doesn't take an immediate)
1264 ;;; (no -C variant as x86 MUL instruction doesn't take an immediate)
1266 (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
1267 fast-ash-c/unsigned=>unsigned)
1268 (:translate ash-left-mod64))
1269 (define-vop (fast-ash-left-mod64/unsigned=>unsigned
1270 fast-ash-left/unsigned=>unsigned))
1271 (deftransform ash-left-mod64 ((integer count)
1272 ((unsigned-byte 64) (unsigned-byte 6)))
1273 (when (sb!c::constant-lvar-p count)
1274 (sb!c::give-up-ir1-transform))
1275 '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
1277 (define-vop (fast-ash-left-smod61-c/fixnum=>fixnum
1278 fast-ash-c/fixnum=>fixnum)
1279 (:translate ash-left-smod61))
1280 (define-vop (fast-ash-left-smod61/fixnum=>fixnum
1281 fast-ash-left/fixnum=>fixnum))
1282 (deftransform ash-left-smod61 ((integer count)
1283 ((signed-byte 61) (unsigned-byte 6)))
1284 (when (sb!c::constant-lvar-p count)
1285 (sb!c::give-up-ir1-transform))
1286 '(%primitive fast-ash-left-smod61/fixnum=>fixnum integer count))
1290 (defknown sb!vm::%lea-mod64 (integer integer (member 1 2 4 8) (signed-byte 64))
1292 (foldable flushable movable))
1293 (defknown sb!vm::%lea-smod61 (integer integer (member 1 2 4 8) (signed-byte 64))
1295 (foldable flushable movable))
1297 (define-modular-fun-optimizer %lea ((base index scale disp) :unsigned :width width)
1298 (when (and (<= width 64)
1299 (constant-lvar-p scale)
1300 (constant-lvar-p disp))
1301 (cut-to-width base :unsigned width)
1302 (cut-to-width index :unsigned width)
1303 'sb!vm::%lea-mod64))
1304 (define-modular-fun-optimizer %lea ((base index scale disp) :signed :width width)
1305 (when (and (<= width 61)
1306 (constant-lvar-p scale)
1307 (constant-lvar-p disp))
1308 (cut-to-width base :signed width)
1309 (cut-to-width index :signed width)
1310 'sb!vm::%lea-smod61))
1314 (defun sb!vm::%lea-mod64 (base index scale disp)
1315 (ldb (byte 64 0) (%lea base index scale disp)))
1316 (defun sb!vm::%lea-smod61 (base index scale disp)
1317 (mask-signed-field 61 (%lea base index scale disp))))
1320 (defun sb!vm::%lea-mod64 (base index scale disp)
1321 (let ((base (logand base #xffffffffffffffff))
1322 (index (logand index #xffffffffffffffff)))
1323 ;; can't use modular version of %LEA, as we only have VOPs for
1324 ;; constant SCALE and DISP.
1325 (ldb (byte 64 0) (+ base (* index scale) disp))))
1326 (defun sb!vm::%lea-smod61 (base index scale disp)
1327 (let ((base (mask-signed-field 61 base))
1328 (index (mask-signed-field 61 index)))
1329 ;; can't use modular version of %LEA, as we only have VOPs for
1330 ;; constant SCALE and DISP.
1331 (mask-signed-field 61 (+ base (* index scale) disp)))))
1333 (in-package "SB!VM")
1335 (define-vop (%lea-mod64/unsigned=>unsigned
1336 %lea/unsigned=>unsigned)
1337 (:translate %lea-mod64))
1338 (define-vop (%lea-smod61/fixnum=>fixnum
1339 %lea/fixnum=>fixnum)
1340 (:translate %lea-smod61))
1342 ;;; logical operations
1343 (define-modular-fun lognot-mod64 (x) lognot :unsigned 64)
1344 (define-vop (lognot-mod64/unsigned=>unsigned)
1345 (:translate lognot-mod64)
1346 (:args (x :scs (unsigned-reg unsigned-stack) :target r
1347 :load-if (not (and (sc-is x unsigned-stack)
1348 (sc-is r unsigned-stack)
1350 (:arg-types unsigned-num)
1351 (:results (r :scs (unsigned-reg)
1352 :load-if (not (and (sc-is x unsigned-stack)
1353 (sc-is r unsigned-stack)
1355 (:result-types unsigned-num)
1356 (:policy :fast-safe)
1361 (define-modular-fun logxor-mod64 (x y) logxor :unsigned 64)
1362 (define-vop (fast-logxor-mod64/unsigned=>unsigned
1363 fast-logxor/unsigned=>unsigned)
1364 (:translate logxor-mod64))
1365 (define-vop (fast-logxor-mod64-c/unsigned=>unsigned
1366 fast-logxor-c/unsigned=>unsigned)
1367 (:translate logxor-mod64))
1368 (define-vop (fast-logxor-mod64/fixnum=>fixnum
1369 fast-logxor/fixnum=>fixnum)
1370 (:translate logxor-mod64))
1371 (define-vop (fast-logxor-mod64-c/fixnum=>fixnum
1372 fast-logxor-c/fixnum=>fixnum)
1373 (:translate logxor-mod64))
1375 (define-source-transform logeqv (&rest args)
1376 (if (oddp (length args))
1378 `(lognot (logxor ,@args))))
1379 (define-source-transform logandc1 (x y)
1380 `(logand (lognot ,x) ,y))
1381 (define-source-transform logandc2 (x y)
1382 `(logand ,x (lognot ,y)))
1383 (define-source-transform logorc1 (x y)
1384 `(logior (lognot ,x) ,y))
1385 (define-source-transform logorc2 (x y)
1386 `(logior ,x (lognot ,y)))
1387 (define-source-transform lognor (x y)
1388 `(lognot (logior ,x ,y)))
1389 (define-source-transform lognand (x y)
1390 `(lognot (logand ,x ,y)))
1394 (define-vop (bignum-length get-header-data)
1395 (:translate sb!bignum:%bignum-length)
1396 (:policy :fast-safe))
1398 (define-vop (bignum-set-length set-header-data)
1399 (:translate sb!bignum:%bignum-set-length)
1400 (:policy :fast-safe))
1402 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
1403 (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
1405 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
1406 (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
1408 (define-vop (digit-0-or-plus)
1409 (:translate sb!bignum:%digit-0-or-plusp)
1410 (:policy :fast-safe)
1411 (:args (digit :scs (unsigned-reg)))
1412 (:arg-types unsigned-num)
1414 (:info target not-p)
1416 (inst or digit digit)
1417 (inst jmp (if not-p :s :ns) target)))
1420 ;;; For add and sub with carry the sc of carry argument is any-reg so
1421 ;;; the it may be passed as a fixnum or word and thus may be 0, 1, or
1422 ;;; 4. This is easy to deal with and may save a fixnum-word
1424 (define-vop (add-w/carry)
1425 (:translate sb!bignum:%add-with-carry)
1426 (:policy :fast-safe)
1427 (:args (a :scs (unsigned-reg) :target result)
1428 (b :scs (unsigned-reg unsigned-stack) :to :eval)
1429 (c :scs (any-reg) :target temp))
1430 (:arg-types unsigned-num unsigned-num positive-fixnum)
1431 (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
1432 (:results (result :scs (unsigned-reg) :from (:argument 0))
1433 (carry :scs (unsigned-reg)))
1434 (:result-types unsigned-num positive-fixnum)
1438 (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
1441 (inst adc carry carry)))
1443 ;;; Note: the borrow is the oppostite of the x86 convention - 1 for no
1444 ;;; borrow and 0 for a borrow.
1445 (define-vop (sub-w/borrow)
1446 (:translate sb!bignum:%subtract-with-borrow)
1447 (:policy :fast-safe)
1448 (:args (a :scs (unsigned-reg) :to :eval :target result)
1449 (b :scs (unsigned-reg unsigned-stack) :to :result)
1450 (c :scs (any-reg control-stack)))
1451 (:arg-types unsigned-num unsigned-num positive-fixnum)
1452 (:results (result :scs (unsigned-reg) :from :eval)
1453 (borrow :scs (unsigned-reg)))
1454 (:result-types unsigned-num positive-fixnum)
1456 (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
1460 (inst adc borrow borrow)
1461 (inst xor borrow 1)))
1464 (define-vop (bignum-mult-and-add-3-arg)
1465 (:translate sb!bignum:%multiply-and-add)
1466 (:policy :fast-safe)
1467 (:args (x :scs (unsigned-reg) :target eax)
1468 (y :scs (unsigned-reg unsigned-stack))
1469 (carry-in :scs (unsigned-reg unsigned-stack)))
1470 (:arg-types unsigned-num unsigned-num unsigned-num)
1471 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1472 :to (:result 1) :target lo) eax)
1473 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1474 :to (:result 0) :target hi) edx)
1475 (:results (hi :scs (unsigned-reg))
1476 (lo :scs (unsigned-reg)))
1477 (:result-types unsigned-num unsigned-num)
1481 (inst add eax carry-in)
1486 (define-vop (bignum-mult-and-add-4-arg)
1487 (:translate sb!bignum:%multiply-and-add)
1488 (:policy :fast-safe)
1489 (:args (x :scs (unsigned-reg) :target eax)
1490 (y :scs (unsigned-reg unsigned-stack))
1491 (prev :scs (unsigned-reg unsigned-stack))
1492 (carry-in :scs (unsigned-reg unsigned-stack)))
1493 (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1494 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1495 :to (:result 1) :target lo) eax)
1496 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1497 :to (:result 0) :target hi) edx)
1498 (:results (hi :scs (unsigned-reg))
1499 (lo :scs (unsigned-reg)))
1500 (:result-types unsigned-num unsigned-num)
1506 (inst add eax carry-in)
1512 (define-vop (bignum-mult)
1513 (:translate sb!bignum:%multiply)
1514 (:policy :fast-safe)
1515 (:args (x :scs (unsigned-reg) :target eax)
1516 (y :scs (unsigned-reg unsigned-stack)))
1517 (:arg-types unsigned-num unsigned-num)
1518 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1519 :to (:result 1) :target lo) eax)
1520 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1521 :to (:result 0) :target hi) edx)
1522 (:results (hi :scs (unsigned-reg))
1523 (lo :scs (unsigned-reg)))
1524 (:result-types unsigned-num unsigned-num)
1531 (define-vop (bignum-lognot lognot-mod64/unsigned=>unsigned)
1532 (:translate sb!bignum:%lognot))
1534 (define-vop (fixnum-to-digit)
1535 (:translate sb!bignum:%fixnum-to-digit)
1536 (:policy :fast-safe)
1537 (:args (fixnum :scs (any-reg control-stack) :target digit))
1538 (:arg-types tagged-num)
1539 (:results (digit :scs (unsigned-reg)
1540 :load-if (not (and (sc-is fixnum control-stack)
1541 (sc-is digit unsigned-stack)
1542 (location= fixnum digit)))))
1543 (:result-types unsigned-num)
1546 (inst sar digit 3)))
1548 (define-vop (bignum-floor)
1549 (:translate sb!bignum:%floor)
1550 (:policy :fast-safe)
1551 (:args (div-high :scs (unsigned-reg) :target edx)
1552 (div-low :scs (unsigned-reg) :target eax)
1553 (divisor :scs (unsigned-reg unsigned-stack)))
1554 (:arg-types unsigned-num unsigned-num unsigned-num)
1555 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
1556 :to (:result 0) :target quo) eax)
1557 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
1558 :to (:result 1) :target rem) edx)
1559 (:results (quo :scs (unsigned-reg))
1560 (rem :scs (unsigned-reg)))
1561 (:result-types unsigned-num unsigned-num)
1565 (inst div eax divisor)
1569 (define-vop (signify-digit)
1570 (:translate sb!bignum:%fixnum-digit-with-correct-sign)
1571 (:policy :fast-safe)
1572 (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
1573 (:arg-types unsigned-num)
1574 (:results (res :scs (any-reg signed-reg)
1575 :load-if (not (and (sc-is digit unsigned-stack)
1576 (sc-is res control-stack signed-stack)
1577 (location= digit res)))))
1578 (:result-types signed-num)
1581 (when (sc-is res any-reg control-stack)
1584 (define-vop (digit-ashr)
1585 (:translate sb!bignum:%ashr)
1586 (:policy :fast-safe)
1587 (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
1588 (count :scs (unsigned-reg) :target ecx))
1589 (:arg-types unsigned-num positive-fixnum)
1590 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
1591 (:results (result :scs (unsigned-reg) :from (:argument 0)
1592 :load-if (not (and (sc-is result unsigned-stack)
1593 (location= digit result)))))
1594 (:result-types unsigned-num)
1598 (inst sar result :cl)))
1600 (define-vop (digit-lshr digit-ashr)
1601 (:translate sb!bignum:%digit-logical-shift-right)
1605 (inst shr result :cl)))
1607 (define-vop (digit-ashl digit-ashr)
1608 (:translate sb!bignum:%ashl)
1612 (inst shl result :cl)))
1614 ;;;; static functions
1616 (define-static-fun two-arg-/ (x y) :translate /)
1618 (define-static-fun two-arg-gcd (x y) :translate gcd)
1619 (define-static-fun two-arg-lcm (x y) :translate lcm)
1621 (define-static-fun two-arg-and (x y) :translate logand)
1622 (define-static-fun two-arg-ior (x y) :translate logior)
1623 (define-static-fun two-arg-xor (x y) :translate logxor)
1628 (defun *-transformer (y)
1630 ((= y (ash 1 (integer-length y)))
1631 ;; there's a generic transform for y = 2^k
1632 (give-up-ir1-transform))
1633 ((member y '(3 5 9))
1634 ;; we can do these multiplications directly using LEA
1635 `(%lea x x ,(1- y) 0))
1637 ;; A normal 64-bit multiplication takes 4 cycles on Athlon 64/Opteron.
1638 ;; Optimizing multiplications (other than the above cases) to
1639 ;; shifts/adds/leas gives a maximum improvement of 1 cycle, but requires
1640 ;; quite a lot of hairy code.
1641 (give-up-ir1-transform))))
1643 (deftransform * ((x y)
1644 ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1646 "recode as leas, shifts and adds"
1647 (let ((y (lvar-value y)))
1649 (deftransform sb!vm::*-mod64
1650 ((x y) ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1652 "recode as leas, shifts and adds"
1653 (let ((y (lvar-value y)))
1656 (deftransform * ((x y)
1657 ((signed-byte 61) (constant-arg (unsigned-byte 64)))
1659 "recode as leas, shifts and adds"
1660 (let ((y (lvar-value y)))
1662 (deftransform sb!vm::*-smod61
1663 ((x y) ((signed-byte 61) (constant-arg (unsigned-byte 64)))
1665 "recode as leas, shifts and adds"
1666 (let ((y (lvar-value y)))