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))
610 (inst xor result result))
612 ;; shift too far then back again, to zero tag bits
613 (inst sar result (- 3 amount))
614 (inst shl result 3)))))))
617 (define-vop (fast-ash-left/fixnum=>fixnum)
619 (:args (number :scs (any-reg) :target result
620 :load-if (not (and (sc-is number control-stack)
621 (sc-is result control-stack)
622 (location= number result))))
623 (amount :scs (unsigned-reg) :target ecx))
624 (:arg-types tagged-num positive-fixnum)
625 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
626 (:results (result :scs (any-reg) :from (:argument 0)
627 :load-if (not (and (sc-is number control-stack)
628 (sc-is result control-stack)
629 (location= number result)))))
630 (:result-types tagged-num)
636 ;; The result-type ensures us that this shift will not overflow.
637 (inst shl result :cl)))
639 (define-vop (fast-ash-c/signed=>signed)
642 (:args (number :scs (signed-reg) :target result
643 :load-if (not (and (sc-is number signed-stack)
644 (sc-is result signed-stack)
645 (location= number result)))))
647 (:arg-types signed-num (:constant integer))
648 (:results (result :scs (signed-reg)
649 :load-if (not (and (sc-is number signed-stack)
650 (sc-is result signed-stack)
651 (location= number result)))))
652 (:result-types signed-num)
655 (cond ((and (= amount 1) (not (location= number result)))
656 (inst lea result (make-ea :qword :index number :scale 2)))
657 ((and (= amount 2) (not (location= number result)))
658 (inst lea result (make-ea :qword :index number :scale 4)))
659 ((and (= amount 3) (not (location= number result)))
660 (inst lea result (make-ea :qword :index number :scale 8)))
663 (cond ((plusp amount) (inst shl result amount))
664 (t (inst sar result (min 63 (- amount)))))))))
666 (define-vop (fast-ash-c/unsigned=>unsigned)
669 (:args (number :scs (unsigned-reg) :target result
670 :load-if (not (and (sc-is number unsigned-stack)
671 (sc-is result unsigned-stack)
672 (location= number result)))))
674 (:arg-types unsigned-num (:constant integer))
675 (:results (result :scs (unsigned-reg)
676 :load-if (not (and (sc-is number unsigned-stack)
677 (sc-is result unsigned-stack)
678 (location= number result)))))
679 (:result-types unsigned-num)
682 (cond ((and (= amount 1) (not (location= number result)))
683 (inst lea result (make-ea :qword :index number :scale 2)))
684 ((and (= amount 2) (not (location= number result)))
685 (inst lea result (make-ea :qword :index number :scale 4)))
686 ((and (= amount 3) (not (location= number result)))
687 (inst lea result (make-ea :qword :index number :scale 8)))
690 (cond ((< -64 amount 64) ;; XXXX
691 ;; this code is used both in ASH and ASH-MOD32, so
694 (inst shl result amount)
695 (inst shr result (- amount))))
696 (t (if (sc-is result unsigned-reg)
697 (inst xor result result)
698 (inst mov result 0))))))))
700 (define-vop (fast-ash-left/signed=>signed)
702 (:args (number :scs (signed-reg) :target result
703 :load-if (not (and (sc-is number signed-stack)
704 (sc-is result signed-stack)
705 (location= number result))))
706 (amount :scs (unsigned-reg) :target ecx))
707 (:arg-types signed-num positive-fixnum)
708 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
709 (:results (result :scs (signed-reg) :from (:argument 0)
710 :load-if (not (and (sc-is number signed-stack)
711 (sc-is result signed-stack)
712 (location= number result)))))
713 (:result-types signed-num)
719 (inst shl result :cl)))
721 (define-vop (fast-ash-left/unsigned=>unsigned)
723 (:args (number :scs (unsigned-reg) :target result
724 :load-if (not (and (sc-is number unsigned-stack)
725 (sc-is result unsigned-stack)
726 (location= number result))))
727 (amount :scs (unsigned-reg) :target ecx))
728 (:arg-types unsigned-num positive-fixnum)
729 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
730 (:results (result :scs (unsigned-reg) :from (:argument 0)
731 :load-if (not (and (sc-is number unsigned-stack)
732 (sc-is result unsigned-stack)
733 (location= number result)))))
734 (:result-types unsigned-num)
740 (inst shl result :cl)))
742 (define-vop (fast-ash/signed=>signed)
745 (:args (number :scs (signed-reg) :target result)
746 (amount :scs (signed-reg) :target ecx))
747 (:arg-types signed-num signed-num)
748 (:results (result :scs (signed-reg) :from (:argument 0)))
749 (:result-types signed-num)
750 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
756 (inst jmp :ns positive)
762 (inst sar result :cl)
766 ;; The result-type ensures us that this shift will not overflow.
767 (inst shl result :cl)
771 (define-vop (fast-ash/unsigned=>unsigned)
774 (:args (number :scs (unsigned-reg) :target result)
775 (amount :scs (signed-reg) :target ecx))
776 (:arg-types unsigned-num signed-num)
777 (:results (result :scs (unsigned-reg) :from (:argument 0)))
778 (:result-types unsigned-num)
779 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
785 (inst jmp :ns positive)
789 (inst xor result result)
792 (inst shr result :cl)
796 ;; The result-type ensures us that this shift will not overflow.
797 (inst shl result :cl)
803 (defknown %lea (integer integer (member 1 2 4 8 16) (signed-byte 64))
805 (foldable flushable movable))
807 (defoptimizer (%lea derive-type) ((base index scale disp))
808 (when (and (constant-lvar-p scale)
809 (constant-lvar-p disp))
810 (let ((scale (lvar-value scale))
811 (disp (lvar-value disp))
812 (base-type (lvar-type base))
813 (index-type (lvar-type index)))
814 (when (and (numeric-type-p base-type)
815 (numeric-type-p index-type))
816 (let ((base-lo (numeric-type-low base-type))
817 (base-hi (numeric-type-high base-type))
818 (index-lo (numeric-type-low index-type))
819 (index-hi (numeric-type-high index-type)))
820 (make-numeric-type :class 'integer
822 :low (when (and base-lo index-lo)
823 (+ base-lo (* index-lo scale) disp))
824 :high (when (and base-hi index-hi)
825 (+ base-hi (* index-hi scale) disp))))))))
827 (defun %lea (base index scale disp)
828 (+ base (* index scale) disp))
832 (define-vop (%lea/unsigned=>unsigned)
835 (:args (base :scs (unsigned-reg))
836 (index :scs (unsigned-reg)))
838 (:arg-types unsigned-num unsigned-num
839 (:constant (member 1 2 4 8))
840 (:constant (signed-byte 64)))
841 (:results (r :scs (unsigned-reg)))
842 (:result-types unsigned-num)
844 (inst lea r (make-ea :qword :base base :index index
845 :scale scale :disp disp))))
847 (define-vop (%lea/signed=>signed)
850 (:args (base :scs (signed-reg))
851 (index :scs (signed-reg)))
853 (:arg-types signed-num signed-num
854 (:constant (member 1 2 4 8))
855 (:constant (signed-byte 64)))
856 (:results (r :scs (signed-reg)))
857 (:result-types signed-num)
859 (inst lea r (make-ea :qword :base base :index index
860 :scale scale :disp disp))))
862 (define-vop (%lea/fixnum=>fixnum)
865 (:args (base :scs (any-reg))
866 (index :scs (any-reg)))
868 (:arg-types tagged-num tagged-num
869 (:constant (member 1 2 4 8))
870 (:constant (signed-byte 64)))
871 (:results (r :scs (any-reg)))
872 (:result-types tagged-num)
874 (inst lea r (make-ea :qword :base base :index index
875 :scale scale :disp disp))))
877 ;;; FIXME: before making knowledge of this too public, it needs to be
878 ;;; fixed so that it's actually _faster_ than the non-CMOV version; at
879 ;;; least on my Celeron-XXX laptop, this version is marginally slower
880 ;;; than the above version with branches. -- CSR, 2003-09-04
881 (define-vop (fast-cmov-ash/unsigned=>unsigned)
884 (:args (number :scs (unsigned-reg) :target result)
885 (amount :scs (signed-reg) :target ecx))
886 (:arg-types unsigned-num signed-num)
887 (:results (result :scs (unsigned-reg) :from (:argument 0)))
888 (:result-types unsigned-num)
889 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
890 (:temporary (:sc any-reg :from (:eval 0) :to (:eval 1)) zero)
892 (:guard (member :cmov *backend-subfeatures*))
897 (inst jmp :ns positive)
900 (inst shr result :cl)
902 (inst cmov :nbe result zero)
906 ;; The result-type ensures us that this shift will not overflow.
907 (inst shl result :cl)
911 ;;; Note: documentation for this function is wrong - rtfm
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 (define-modular-fun +-mod64 (x y) + :unsigned 64)
1238 (define-vop (fast-+-mod64/unsigned=>unsigned fast-+/unsigned=>unsigned)
1239 (:translate +-mod64))
1240 (define-vop (fast-+-mod64-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned)
1241 (:translate +-mod64))
1242 (define-modular-fun --mod64 (x y) - :unsigned 64)
1243 (define-vop (fast---mod64/unsigned=>unsigned fast--/unsigned=>unsigned)
1244 (:translate --mod64))
1245 (define-vop (fast---mod64-c/unsigned=>unsigned fast---c/unsigned=>unsigned)
1246 (:translate --mod64))
1248 (define-modular-fun *-mod64 (x y) * :unsigned 64)
1249 (define-vop (fast-*-mod64/unsigned=>unsigned fast-*/unsigned=>unsigned)
1250 (:translate *-mod64))
1251 ;;; (no -C variant as x86 MUL instruction doesn't take an immediate)
1253 (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
1254 fast-ash-c/unsigned=>unsigned)
1255 (:translate ash-left-mod64))
1256 (define-vop (fast-ash-left-mod64/unsigned=>unsigned
1257 fast-ash-left/unsigned=>unsigned))
1258 (deftransform ash-left-mod64 ((integer count)
1259 ((unsigned-byte 64) (unsigned-byte 6)))
1260 (when (sb!c::constant-lvar-p count)
1261 (sb!c::give-up-ir1-transform))
1262 '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
1266 (defknown sb!vm::%lea-mod64 (integer integer (member 1 2 4 8) (signed-byte 64))
1268 (foldable flushable movable))
1270 (define-modular-fun-optimizer %lea ((base index scale disp) :unsigned :width width)
1271 (when (and (<= width 64)
1272 (constant-lvar-p scale)
1273 (constant-lvar-p disp))
1274 (cut-to-width base :unsigned width)
1275 (cut-to-width index :unsigned width)
1276 'sb!vm::%lea-mod64))
1279 (defun sb!vm::%lea-mod64 (base index scale disp)
1280 (ldb (byte 64 0) (%lea base index scale disp)))
1282 (defun sb!vm::%lea-mod64 (base index scale disp)
1283 (let ((base (logand base #xffffffffffffffff))
1284 (index (logand index #xffffffffffffffff)))
1285 ;; can't use modular version of %LEA, as we only have VOPs for
1286 ;; constant SCALE and DISP.
1287 (ldb (byte 64 0) (+ base (* index scale) disp))))
1289 (in-package "SB!VM")
1291 (define-vop (%lea-mod64/unsigned=>unsigned
1292 %lea/unsigned=>unsigned)
1293 (:translate %lea-mod64))
1295 ;;; logical operations
1296 (define-modular-fun lognot-mod64 (x) lognot :unsigned 64)
1297 (define-vop (lognot-mod64/unsigned=>unsigned)
1298 (:translate lognot-mod64)
1299 (:args (x :scs (unsigned-reg unsigned-stack) :target r
1300 :load-if (not (and (sc-is x unsigned-stack)
1301 (sc-is r unsigned-stack)
1303 (:arg-types unsigned-num)
1304 (:results (r :scs (unsigned-reg)
1305 :load-if (not (and (sc-is x unsigned-stack)
1306 (sc-is r unsigned-stack)
1308 (:result-types unsigned-num)
1309 (:policy :fast-safe)
1314 (define-modular-fun logxor-mod64 (x y) logxor :unsigned 64)
1315 (define-vop (fast-logxor-mod64/unsigned=>unsigned
1316 fast-logxor/unsigned=>unsigned)
1317 (:translate logxor-mod64))
1318 (define-vop (fast-logxor-mod64-c/unsigned=>unsigned
1319 fast-logxor-c/unsigned=>unsigned)
1320 (:translate logxor-mod64))
1322 (define-source-transform logeqv (&rest args)
1323 (if (oddp (length args))
1325 `(lognot (logxor ,@args))))
1326 (define-source-transform logandc1 (x y)
1327 `(logand (lognot ,x) ,y))
1328 (define-source-transform logandc2 (x y)
1329 `(logand ,x (lognot ,y)))
1330 (define-source-transform logorc1 (x y)
1331 `(logior (lognot ,x) ,y))
1332 (define-source-transform logorc2 (x y)
1333 `(logior ,x (lognot ,y)))
1334 (define-source-transform lognor (x y)
1335 `(lognot (logior ,x ,y)))
1336 (define-source-transform lognand (x y)
1337 `(lognot (logand ,x ,y)))
1341 (define-vop (bignum-length get-header-data)
1342 (:translate sb!bignum:%bignum-length)
1343 (:policy :fast-safe))
1345 (define-vop (bignum-set-length set-header-data)
1346 (:translate sb!bignum:%bignum-set-length)
1347 (:policy :fast-safe))
1349 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
1350 (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
1352 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
1353 (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
1355 (define-vop (digit-0-or-plus)
1356 (:translate sb!bignum:%digit-0-or-plusp)
1357 (:policy :fast-safe)
1358 (:args (digit :scs (unsigned-reg)))
1359 (:arg-types unsigned-num)
1361 (:info target not-p)
1363 (inst or digit digit)
1364 (inst jmp (if not-p :s :ns) target)))
1367 ;;; For add and sub with carry the sc of carry argument is any-reg so
1368 ;;; the it may be passed as a fixnum or word and thus may be 0, 1, or
1369 ;;; 4. This is easy to deal with and may save a fixnum-word
1371 (define-vop (add-w/carry)
1372 (:translate sb!bignum:%add-with-carry)
1373 (:policy :fast-safe)
1374 (:args (a :scs (unsigned-reg) :target result)
1375 (b :scs (unsigned-reg unsigned-stack) :to :eval)
1376 (c :scs (any-reg) :target temp))
1377 (:arg-types unsigned-num unsigned-num positive-fixnum)
1378 (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
1379 (:results (result :scs (unsigned-reg) :from (:argument 0))
1380 (carry :scs (unsigned-reg)))
1381 (:result-types unsigned-num positive-fixnum)
1385 (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
1388 (inst adc carry carry)))
1390 ;;; Note: the borrow is the oppostite of the x86 convention - 1 for no
1391 ;;; borrow and 0 for a borrow.
1392 (define-vop (sub-w/borrow)
1393 (:translate sb!bignum:%subtract-with-borrow)
1394 (:policy :fast-safe)
1395 (:args (a :scs (unsigned-reg) :to :eval :target result)
1396 (b :scs (unsigned-reg unsigned-stack) :to :result)
1397 (c :scs (any-reg control-stack)))
1398 (:arg-types unsigned-num unsigned-num positive-fixnum)
1399 (:results (result :scs (unsigned-reg) :from :eval)
1400 (borrow :scs (unsigned-reg)))
1401 (:result-types unsigned-num positive-fixnum)
1403 (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
1407 (inst adc borrow borrow)
1408 (inst xor borrow 1)))
1411 (define-vop (bignum-mult-and-add-3-arg)
1412 (:translate sb!bignum:%multiply-and-add)
1413 (:policy :fast-safe)
1414 (:args (x :scs (unsigned-reg) :target eax)
1415 (y :scs (unsigned-reg unsigned-stack))
1416 (carry-in :scs (unsigned-reg unsigned-stack)))
1417 (:arg-types unsigned-num unsigned-num unsigned-num)
1418 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1419 :to (:result 1) :target lo) eax)
1420 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1421 :to (:result 0) :target hi) edx)
1422 (:results (hi :scs (unsigned-reg))
1423 (lo :scs (unsigned-reg)))
1424 (:result-types unsigned-num unsigned-num)
1428 (inst add eax carry-in)
1433 (define-vop (bignum-mult-and-add-4-arg)
1434 (:translate sb!bignum:%multiply-and-add)
1435 (:policy :fast-safe)
1436 (:args (x :scs (unsigned-reg) :target eax)
1437 (y :scs (unsigned-reg unsigned-stack))
1438 (prev :scs (unsigned-reg unsigned-stack))
1439 (carry-in :scs (unsigned-reg unsigned-stack)))
1440 (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1441 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1442 :to (:result 1) :target lo) eax)
1443 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1444 :to (:result 0) :target hi) edx)
1445 (:results (hi :scs (unsigned-reg))
1446 (lo :scs (unsigned-reg)))
1447 (:result-types unsigned-num unsigned-num)
1453 (inst add eax carry-in)
1459 (define-vop (bignum-mult)
1460 (:translate sb!bignum:%multiply)
1461 (:policy :fast-safe)
1462 (:args (x :scs (unsigned-reg) :target eax)
1463 (y :scs (unsigned-reg unsigned-stack)))
1464 (:arg-types unsigned-num unsigned-num)
1465 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1466 :to (:result 1) :target lo) eax)
1467 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1468 :to (:result 0) :target hi) edx)
1469 (:results (hi :scs (unsigned-reg))
1470 (lo :scs (unsigned-reg)))
1471 (:result-types unsigned-num unsigned-num)
1478 (define-vop (bignum-lognot lognot-mod64/unsigned=>unsigned)
1479 (:translate sb!bignum:%lognot))
1481 (define-vop (fixnum-to-digit)
1482 (:translate sb!bignum:%fixnum-to-digit)
1483 (:policy :fast-safe)
1484 (:args (fixnum :scs (any-reg control-stack) :target digit))
1485 (:arg-types tagged-num)
1486 (:results (digit :scs (unsigned-reg)
1487 :load-if (not (and (sc-is fixnum control-stack)
1488 (sc-is digit unsigned-stack)
1489 (location= fixnum digit)))))
1490 (:result-types unsigned-num)
1493 (inst sar digit 3)))
1495 (define-vop (bignum-floor)
1496 (:translate sb!bignum:%floor)
1497 (:policy :fast-safe)
1498 (:args (div-high :scs (unsigned-reg) :target edx)
1499 (div-low :scs (unsigned-reg) :target eax)
1500 (divisor :scs (unsigned-reg unsigned-stack)))
1501 (:arg-types unsigned-num unsigned-num unsigned-num)
1502 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
1503 :to (:result 0) :target quo) eax)
1504 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
1505 :to (:result 1) :target rem) edx)
1506 (:results (quo :scs (unsigned-reg))
1507 (rem :scs (unsigned-reg)))
1508 (:result-types unsigned-num unsigned-num)
1512 (inst div eax divisor)
1516 (define-vop (signify-digit)
1517 (:translate sb!bignum:%fixnum-digit-with-correct-sign)
1518 (:policy :fast-safe)
1519 (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
1520 (:arg-types unsigned-num)
1521 (:results (res :scs (any-reg signed-reg)
1522 :load-if (not (and (sc-is digit unsigned-stack)
1523 (sc-is res control-stack signed-stack)
1524 (location= digit res)))))
1525 (:result-types signed-num)
1528 (when (sc-is res any-reg control-stack)
1531 (define-vop (digit-ashr)
1532 (:translate sb!bignum:%ashr)
1533 (:policy :fast-safe)
1534 (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
1535 (count :scs (unsigned-reg) :target ecx))
1536 (:arg-types unsigned-num positive-fixnum)
1537 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
1538 (:results (result :scs (unsigned-reg) :from (:argument 0)
1539 :load-if (not (and (sc-is result unsigned-stack)
1540 (location= digit result)))))
1541 (:result-types unsigned-num)
1545 (inst sar result :cl)))
1547 (define-vop (digit-lshr digit-ashr)
1548 (:translate sb!bignum:%digit-logical-shift-right)
1552 (inst shr result :cl)))
1554 (define-vop (digit-ashl digit-ashr)
1555 (:translate sb!bignum:%ashl)
1559 (inst shl result :cl)))
1561 ;;;; static functions
1563 (define-static-fun two-arg-/ (x y) :translate /)
1565 (define-static-fun two-arg-gcd (x y) :translate gcd)
1566 (define-static-fun two-arg-lcm (x y) :translate lcm)
1568 (define-static-fun two-arg-and (x y) :translate logand)
1569 (define-static-fun two-arg-ior (x y) :translate logior)
1570 (define-static-fun two-arg-xor (x y) :translate logxor)
1575 ;;; This is essentially a straight implementation of the algorithm in
1576 ;;; "Strength Reduction of Multiplications by Integer Constants",
1577 ;;; Youfeng Wu, ACM SIGPLAN Notices, Vol. 30, No.2, February 1995.
1578 (defun basic-decompose-multiplication (arg num n-bits condensed)
1579 (case (aref condensed 0)
1581 (let ((tmp (min 3 (aref condensed 1))))
1582 (decf (aref condensed 1) tmp)
1585 ,(decompose-multiplication
1586 arg (ash (1- num) (- tmp)) (1- n-bits) (subseq condensed 1))
1589 (let ((r0 (aref condensed 0)))
1590 (incf (aref condensed 1) r0)
1592 (%lea ,(decompose-multiplication
1593 arg (- num (ash 1 r0)) (1- n-bits) (subseq condensed 1))
1596 (t (let ((r0 (aref condensed 0)))
1597 (setf (aref condensed 0) 0)
1599 (ash ,(decompose-multiplication
1600 arg (ash num (- r0)) n-bits condensed)
1603 (defun decompose-multiplication (arg num n-bits condensed)
1608 `(logand #xffffffff (ash ,arg ,(1- (integer-length num)))))
1609 ((let ((max 0) (end 0))
1610 (loop for i from 2 to (length condensed)
1611 for j = (reduce #'+ (subseq condensed 0 i))
1612 when (and (> (- (* 2 i) 3 j) max)
1613 (< (+ (ash 1 (1+ j))
1614 (ash (ldb (byte (- 64 (1+ j)) (1+ j)) num)
1617 do (setq max (- (* 2 i) 3 j)
1620 (let ((j (reduce #'+ (subseq condensed 0 end))))
1621 (let ((n2 (+ (ash 1 (1+ j))
1622 (ash (ldb (byte (- 64 (1+ j)) (1+ j)) num) (1+ j))))
1623 (n1 (1+ (ldb (byte (1+ j) 0) (lognot num)))))
1625 (- ,(optimize-multiply arg n2) ,(optimize-multiply arg n1))))))))
1626 ((dolist (i '(9 5 3))
1627 (when (integerp (/ num i))
1628 (when (< (logcount (/ num i)) (logcount num))
1630 (return `(let ((,x ,(optimize-multiply arg (/ num i))))
1632 (%lea ,x ,x (1- ,i) 0)))))))))
1633 (t (basic-decompose-multiplication arg num n-bits condensed))))
1635 (defun optimize-multiply (arg x)
1636 (let* ((n-bits (logcount x))
1637 (condensed (make-array n-bits)))
1638 (let ((count 0) (bit 0))
1640 (cond ((logbitp i x)
1641 (setf (aref condensed bit) count)
1645 (decompose-multiplication arg x n-bits condensed)))
1647 (defun *-transformer (y)
1649 (t (give-up-ir1-transform))
1650 ((= y (ash 1 (integer-length y)))
1651 ;; there's a generic transform for y = 2^k
1652 (give-up-ir1-transform))
1653 ((member y '(3 5 9))
1654 ;; we can do these multiplications directly using LEA
1655 `(%lea x x ,(1- y) 0))
1656 ((member :pentium4 *backend-subfeatures*)
1657 ;; the pentium4's multiply unit is reportedly very good
1658 (give-up-ir1-transform))
1659 ;; FIXME: should make this more fine-grained. If nothing else,
1660 ;; there should probably be a cutoff of about 9 instructions on
1661 ;; pentium-class machines.
1662 (t (optimize-multiply 'x y))))
1664 (deftransform * ((x y)
1665 ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1667 "recode as leas, shifts and adds"
1668 (let ((y (lvar-value y)))
1671 (deftransform sb!vm::*-mod64
1672 ((x y) ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1674 "recode as leas, shifts and adds"
1675 (let ((y (lvar-value y)))
1678 ;;; FIXME: we should also be able to write an optimizer or two to
1679 ;;; convert (+ (* x 2) 17), (- (* x 9) 5) to a %LEA.