1 ;;;; the VM definition 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.
19 (define-vop (fast-safe-arith-op)
24 (define-vop (fixnum-unop fast-safe-arith-op)
25 (:args (x :scs (any-reg) :target res))
26 (:results (res :scs (any-reg)))
27 (:note "inline fixnum arithmetic")
28 (:arg-types tagged-num)
29 (:result-types tagged-num))
31 (define-vop (signed-unop fast-safe-arith-op)
32 (:args (x :scs (signed-reg) :target res))
33 (:results (res :scs (signed-reg)))
34 (:note "inline (signed-byte 32) arithmetic")
35 (:arg-types signed-num)
36 (:result-types signed-num))
38 (define-vop (fast-negate/fixnum fixnum-unop)
44 (define-vop (fast-negate/signed signed-unop)
50 (define-vop (fast-lognot/fixnum fixnum-unop)
54 (inst xor res (fixnumize -1))))
56 (define-vop (fast-lognot/signed signed-unop)
62 ;;;; binary fixnum operations
64 ;;; Assume that any constant operand is the second arg...
66 (define-vop (fast-fixnum-binop fast-safe-arith-op)
67 (:args (x :target r :scs (any-reg)
68 :load-if (not (and (sc-is x control-stack)
70 (sc-is r control-stack)
72 (y :scs (any-reg control-stack)))
73 (:arg-types tagged-num tagged-num)
74 (:results (r :scs (any-reg) :from (:argument 0)
75 :load-if (not (and (sc-is x control-stack)
77 (sc-is r control-stack)
79 (:result-types tagged-num)
80 (:note "inline fixnum arithmetic"))
82 (define-vop (fast-unsigned-binop fast-safe-arith-op)
83 (:args (x :target r :scs (unsigned-reg)
84 :load-if (not (and (sc-is x unsigned-stack)
85 (sc-is y unsigned-reg)
86 (sc-is r unsigned-stack)
88 (y :scs (unsigned-reg unsigned-stack)))
89 (:arg-types unsigned-num unsigned-num)
90 (:results (r :scs (unsigned-reg) :from (:argument 0)
91 :load-if (not (and (sc-is x unsigned-stack)
92 (sc-is y unsigned-reg)
93 (sc-is r unsigned-stack)
95 (:result-types unsigned-num)
96 (:note "inline (unsigned-byte 32) arithmetic"))
98 (define-vop (fast-signed-binop fast-safe-arith-op)
99 (:args (x :target r :scs (signed-reg)
100 :load-if (not (and (sc-is x signed-stack)
102 (sc-is r signed-stack)
104 (y :scs (signed-reg signed-stack)))
105 (:arg-types signed-num signed-num)
106 (:results (r :scs (signed-reg) :from (:argument 0)
107 :load-if (not (and (sc-is x signed-stack)
109 (sc-is r signed-stack)
111 (:result-types signed-num)
112 (:note "inline (signed-byte 32) arithmetic"))
114 (define-vop (fast-fixnum-binop-c fast-safe-arith-op)
115 (:args (x :target r :scs (any-reg control-stack)))
117 (:arg-types tagged-num (:constant (signed-byte 30)))
118 (:results (r :scs (any-reg)
119 :load-if (not (location= x r))))
120 (:result-types tagged-num)
121 (:note "inline fixnum arithmetic"))
123 (define-vop (fast-unsigned-binop-c fast-safe-arith-op)
124 (:args (x :target r :scs (unsigned-reg unsigned-stack)))
126 (:arg-types unsigned-num (:constant (unsigned-byte 32)))
127 (:results (r :scs (unsigned-reg)
128 :load-if (not (location= x r))))
129 (:result-types unsigned-num)
130 (:note "inline (unsigned-byte 32) arithmetic"))
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))
191 ;;; Special handling of add on the x86; can use lea to avoid a
192 ;;; register load, otherwise it uses add.
193 (define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op)
195 (:args (x :scs (any-reg) :target r
196 :load-if (not (and (sc-is x control-stack)
198 (sc-is r control-stack)
200 (y :scs (any-reg control-stack)))
201 (:arg-types tagged-num tagged-num)
202 (:results (r :scs (any-reg) :from (:argument 0)
203 :load-if (not (and (sc-is x control-stack)
205 (sc-is r control-stack)
207 (:result-types tagged-num)
208 (:note "inline fixnum arithmetic")
210 (cond ((and (sc-is x any-reg) (sc-is y any-reg) (sc-is r any-reg)
211 (not (location= x r)))
212 (inst lea r (make-ea :dword :base x :index y :scale 1)))
217 (define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op)
219 (:args (x :target r :scs (any-reg control-stack)))
221 (:arg-types tagged-num (:constant (signed-byte 30)))
222 (:results (r :scs (any-reg)
223 :load-if (not (location= x r))))
224 (:result-types tagged-num)
225 (:note "inline fixnum arithmetic")
227 (cond ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r)))
228 (inst lea r (make-ea :dword :base x :disp (fixnumize y))))
231 (inst add r (fixnumize y))))))
233 (define-vop (fast-+/signed=>signed fast-safe-arith-op)
235 (:args (x :scs (signed-reg) :target r
236 :load-if (not (and (sc-is x signed-stack)
238 (sc-is r signed-stack)
240 (y :scs (signed-reg signed-stack)))
241 (:arg-types signed-num signed-num)
242 (:results (r :scs (signed-reg) :from (:argument 0)
243 :load-if (not (and (sc-is x signed-stack)
246 (:result-types signed-num)
247 (:note "inline (signed-byte 32) arithmetic")
249 (cond ((and (sc-is x signed-reg) (sc-is y signed-reg) (sc-is r signed-reg)
250 (not (location= x r)))
251 (inst lea r (make-ea :dword :base x :index y :scale 1)))
256 (define-vop (fast-+-c/signed=>signed fast-safe-arith-op)
258 (:args (x :target r :scs (signed-reg signed-stack)))
260 (:arg-types signed-num (:constant (signed-byte 32)))
261 (:results (r :scs (signed-reg)
262 :load-if (not (location= x r))))
263 (:result-types signed-num)
264 (:note "inline (signed-byte 32) arithmetic")
266 (cond ((and (sc-is x signed-reg) (sc-is r signed-reg)
267 (not (location= x r)))
268 (inst lea r (make-ea :dword :base x :disp y)))
275 (define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op)
277 (:args (x :scs (unsigned-reg) :target r
278 :load-if (not (and (sc-is x unsigned-stack)
279 (sc-is y unsigned-reg)
280 (sc-is r unsigned-stack)
282 (y :scs (unsigned-reg unsigned-stack)))
283 (:arg-types unsigned-num unsigned-num)
284 (:results (r :scs (unsigned-reg) :from (:argument 0)
285 :load-if (not (and (sc-is x unsigned-stack)
286 (sc-is y unsigned-reg)
287 (sc-is r unsigned-stack)
289 (:result-types unsigned-num)
290 (:note "inline (unsigned-byte 32) arithmetic")
292 (cond ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg)
293 (sc-is r unsigned-reg) (not (location= x r)))
294 (inst lea r (make-ea :dword :base x :index y :scale 1)))
299 (define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op)
301 (:args (x :target r :scs (unsigned-reg unsigned-stack)))
303 (:arg-types unsigned-num (:constant (unsigned-byte 32)))
304 (:results (r :scs (unsigned-reg)
305 :load-if (not (location= x r))))
306 (:result-types unsigned-num)
307 (:note "inline (unsigned-byte 32) arithmetic")
309 (cond ((and (sc-is x unsigned-reg) (sc-is r unsigned-reg)
310 (not (location= x r)))
311 (inst lea r (make-ea :dword :base x :disp y)))
318 ;;;; multiplication and division
320 (define-vop (fast-*/fixnum=>fixnum fast-safe-arith-op)
322 ;; We need different loading characteristics.
323 (:args (x :scs (any-reg) :target r)
324 (y :scs (any-reg control-stack)))
325 (:arg-types tagged-num tagged-num)
326 (:results (r :scs (any-reg) :from (:argument 0)))
327 (:result-types tagged-num)
328 (:note "inline fixnum arithmetic")
334 (define-vop (fast-*-c/fixnum=>fixnum fast-safe-arith-op)
336 ;; We need different loading characteristics.
337 (:args (x :scs (any-reg control-stack)))
339 (:arg-types tagged-num (:constant (signed-byte 30)))
340 (:results (r :scs (any-reg)))
341 (:result-types tagged-num)
342 (:note "inline fixnum arithmetic")
346 (define-vop (fast-*/signed=>signed fast-safe-arith-op)
348 ;; We need different loading characteristics.
349 (:args (x :scs (signed-reg) :target r)
350 (y :scs (signed-reg signed-stack)))
351 (:arg-types signed-num signed-num)
352 (:results (r :scs (signed-reg) :from (:argument 0)))
353 (:result-types signed-num)
354 (:note "inline (signed-byte 32) arithmetic")
359 (define-vop (fast-*-c/signed=>signed fast-safe-arith-op)
361 ;; We need different loading characteristics.
362 (:args (x :scs (signed-reg signed-stack)))
364 (:arg-types signed-num (:constant (signed-byte 32)))
365 (:results (r :scs (signed-reg)))
366 (:result-types signed-num)
367 (:note "inline (signed-byte 32) arithmetic")
371 (define-vop (fast-*/unsigned=>unsigned fast-safe-arith-op)
373 (:args (x :scs (unsigned-reg) :target eax)
374 (y :scs (unsigned-reg unsigned-stack)))
375 (:arg-types unsigned-num unsigned-num)
376 (:temporary (:sc unsigned-reg :offset eax-offset :target result
377 :from (:argument 0) :to :result) eax)
378 (:temporary (:sc unsigned-reg :offset edx-offset
379 :from :eval :to :result) edx)
381 (:results (result :scs (unsigned-reg)))
382 (:result-types unsigned-num)
383 (:note "inline (unsigned-byte 32) arithmetic")
385 (:save-p :compute-only)
392 (define-vop (fast-truncate/fixnum=>fixnum fast-safe-arith-op)
393 (:translate truncate)
394 (:args (x :scs (any-reg) :target eax)
395 (y :scs (any-reg control-stack)))
396 (:arg-types tagged-num tagged-num)
397 (:temporary (:sc signed-reg :offset eax-offset :target quo
398 :from (:argument 0) :to (:result 0)) eax)
399 (:temporary (:sc unsigned-reg :offset edx-offset :target rem
400 :from (:argument 0) :to (:result 1)) edx)
401 (:results (quo :scs (any-reg))
402 (rem :scs (any-reg)))
403 (:result-types tagged-num tagged-num)
404 (:note "inline fixnum arithmetic")
406 (:save-p :compute-only)
408 (let ((zero (generate-error-code vop division-by-zero-error x y)))
409 (if (sc-is y any-reg)
410 (inst test y y) ; smaller instruction
416 (if (location= quo eax)
418 (inst lea quo (make-ea :dword :index eax :scale 4)))
421 (define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
422 (:translate truncate)
423 (:args (x :scs (any-reg) :target eax))
425 (:arg-types tagged-num (:constant (signed-byte 30)))
426 (:temporary (:sc signed-reg :offset eax-offset :target quo
427 :from :argument :to (:result 0)) eax)
428 (:temporary (:sc any-reg :offset edx-offset :target rem
429 :from :eval :to (:result 1)) edx)
430 (:temporary (:sc any-reg :from :eval :to :result) y-arg)
431 (:results (quo :scs (any-reg))
432 (rem :scs (any-reg)))
433 (:result-types tagged-num tagged-num)
434 (:note "inline fixnum arithmetic")
436 (:save-p :compute-only)
440 (inst mov y-arg (fixnumize y))
441 (inst idiv eax y-arg)
442 (if (location= quo eax)
444 (inst lea quo (make-ea :dword :index eax :scale 4)))
447 (define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
448 (:translate truncate)
449 (:args (x :scs (unsigned-reg) :target eax)
450 (y :scs (unsigned-reg signed-stack)))
451 (:arg-types unsigned-num unsigned-num)
452 (:temporary (:sc unsigned-reg :offset eax-offset :target quo
453 :from (:argument 0) :to (:result 0)) eax)
454 (:temporary (:sc unsigned-reg :offset edx-offset :target rem
455 :from (:argument 0) :to (:result 1)) edx)
456 (:results (quo :scs (unsigned-reg))
457 (rem :scs (unsigned-reg)))
458 (:result-types unsigned-num unsigned-num)
459 (:note "inline (unsigned-byte 32) arithmetic")
461 (:save-p :compute-only)
463 (let ((zero (generate-error-code vop division-by-zero-error x y)))
464 (if (sc-is y unsigned-reg)
465 (inst test y y) ; smaller instruction
474 (define-vop (fast-truncate-c/unsigned=>unsigned fast-safe-arith-op)
475 (:translate truncate)
476 (:args (x :scs (unsigned-reg) :target eax))
478 (:arg-types unsigned-num (:constant (unsigned-byte 32)))
479 (:temporary (:sc unsigned-reg :offset eax-offset :target quo
480 :from :argument :to (:result 0)) eax)
481 (:temporary (:sc unsigned-reg :offset edx-offset :target rem
482 :from :eval :to (:result 1)) edx)
483 (:temporary (:sc unsigned-reg :from :eval :to :result) y-arg)
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)
498 (define-vop (fast-truncate/signed=>signed fast-safe-arith-op)
499 (:translate truncate)
500 (:args (x :scs (signed-reg) :target eax)
501 (y :scs (signed-reg signed-stack)))
502 (:arg-types signed-num signed-num)
503 (:temporary (:sc signed-reg :offset eax-offset :target quo
504 :from (:argument 0) :to (:result 0)) eax)
505 (:temporary (:sc signed-reg :offset edx-offset :target rem
506 :from (:argument 0) :to (:result 1)) edx)
507 (:results (quo :scs (signed-reg))
508 (rem :scs (signed-reg)))
509 (:result-types signed-num signed-num)
510 (:note "inline (signed-byte 32) arithmetic")
512 (:save-p :compute-only)
514 (let ((zero (generate-error-code vop division-by-zero-error x y)))
515 (if (sc-is y signed-reg)
516 (inst test y y) ; smaller instruction
525 (define-vop (fast-truncate-c/signed=>signed fast-safe-arith-op)
526 (:translate truncate)
527 (:args (x :scs (signed-reg) :target eax))
529 (:arg-types signed-num (:constant (signed-byte 32)))
530 (:temporary (:sc signed-reg :offset eax-offset :target quo
531 :from :argument :to (:result 0)) eax)
532 (:temporary (:sc signed-reg :offset edx-offset :target rem
533 :from :eval :to (:result 1)) edx)
534 (:temporary (:sc signed-reg :from :eval :to :result) y-arg)
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)
545 (inst idiv eax y-arg)
552 (define-vop (fast-ash-c/fixnum=>fixnum)
555 (:args (number :scs (any-reg) :target result
556 :load-if (not (and (sc-is number any-reg control-stack)
557 (sc-is result any-reg control-stack)
558 (location= number result)))))
560 (:arg-types tagged-num (:constant integer))
561 (:results (result :scs (any-reg)
562 :load-if (not (and (sc-is number control-stack)
563 (sc-is result control-stack)
564 (location= number result)))))
565 (:result-types tagged-num)
568 (cond ((and (= amount 1) (not (location= number result)))
569 (inst lea result (make-ea :dword :index number :scale 2)))
570 ((and (= amount 2) (not (location= number result)))
571 (inst lea result (make-ea :dword :index number :scale 4)))
572 ((and (= amount 3) (not (location= number result)))
573 (inst lea result (make-ea :dword :index number :scale 8)))
576 (cond ((plusp amount)
577 ;; We don't have to worry about overflow because of the
578 ;; result type restriction.
579 (inst shl result amount))
581 ;; If the amount is greater than 31, only shift by 31. We
582 ;; have to do this because the shift instructions only look
583 ;; at the low five bits of the result.
584 (inst sar result (min 31 (- amount)))
585 ;; Fixnum correction.
586 (inst and result #xfffffffc)))))))
588 (define-vop (fast-ash-left/fixnum=>fixnum)
590 (:args (number :scs (any-reg) :target result
591 :load-if (not (and (sc-is number control-stack)
592 (sc-is result control-stack)
593 (location= number result))))
594 (amount :scs (unsigned-reg) :target ecx))
595 (:arg-types tagged-num positive-fixnum)
596 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
597 (:results (result :scs (any-reg) :from (:argument 0)
598 :load-if (not (and (sc-is number control-stack)
599 (sc-is result control-stack)
600 (location= number result)))))
601 (:result-types tagged-num)
607 ;; The result-type ensures us that this shift will not overflow.
608 (inst shl result :cl)))
610 (define-vop (fast-ash-c)
613 (:args (number :scs (signed-reg unsigned-reg) :target result
614 :load-if (not (and (sc-is number signed-stack unsigned-stack)
615 (sc-is result signed-stack unsigned-stack)
616 (location= number result)))))
618 (:arg-types (:or signed-num unsigned-num) (:constant integer))
619 (:results (result :scs (signed-reg unsigned-reg)
621 (and (sc-is number signed-stack unsigned-stack)
622 (sc-is result signed-stack unsigned-stack)
623 (location= number result)))))
624 (:result-types (:or signed-num unsigned-num))
627 (cond ((and (= amount 1) (not (location= number result)))
628 (inst lea result (make-ea :dword :index number :scale 2)))
629 ((and (= amount 2) (not (location= number result)))
630 (inst lea result (make-ea :dword :index number :scale 4)))
631 ((and (= amount 3) (not (location= number result)))
632 (inst lea result (make-ea :dword :index number :scale 8)))
635 (cond ((plusp amount)
636 ;; We don't have to worry about overflow because of the
637 ;; result type restriction.
638 (inst shl result amount))
639 ((sc-is number signed-reg signed-stack)
640 ;; If the amount is greater than 31, only shift by 31. We
641 ;; have to do this because the shift instructions only look
642 ;; at the low five bits of the result.
643 (inst sar result (min 31 (- amount))))
645 (inst shr result (min 31 (- amount)))))))))
647 (define-vop (fast-ash-left)
649 (:args (number :scs (signed-reg unsigned-reg) :target result
650 :load-if (not (and (sc-is number signed-stack unsigned-stack)
651 (sc-is result signed-stack unsigned-stack)
652 (location= number result))))
653 (amount :scs (unsigned-reg) :target ecx))
654 (:arg-types (:or signed-num unsigned-num) positive-fixnum)
655 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
656 (:results (result :scs (signed-reg unsigned-reg) :from (:argument 0)
658 (and (sc-is number signed-stack unsigned-stack)
659 (sc-is result signed-stack unsigned-stack)
660 (location= number result)))))
661 (:result-types (:or signed-num unsigned-num))
667 ;; The result-type ensures us that this shift will not overflow.
668 (inst shl result :cl)))
670 (define-vop (fast-ash)
673 (:args (number :scs (signed-reg unsigned-reg) :target result)
674 (amount :scs (signed-reg) :target ecx))
675 (:arg-types (:or signed-num unsigned-num) signed-num)
676 (:results (result :scs (signed-reg unsigned-reg) :from (:argument 0)))
677 (:result-types (:or signed-num unsigned-num))
678 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
684 (inst jmp :ns positive)
691 (signed-reg (inst sar result :cl))
692 (unsigned-reg (inst shr result :cl)))
696 ;; The result-type ensures us that this shift will not overflow.
697 (inst shl result :cl)
701 ;;; Note: documentation for this function is wrong - rtfm
702 (define-vop (signed-byte-32-len)
703 (:translate integer-length)
704 (:note "inline (signed-byte 32) integer-length")
706 (:args (arg :scs (signed-reg) :target res))
707 (:arg-types signed-num)
708 (:results (res :scs (any-reg)))
709 (:result-types positive-fixnum)
725 (define-vop (unsigned-byte-32-count)
726 (:translate logcount)
727 (:note "inline (unsigned-byte 32) logcount")
729 (:args (arg :scs (unsigned-reg)))
730 (:arg-types unsigned-num)
731 (:results (result :scs (unsigned-reg)))
732 (:result-types positive-fixnum)
733 (:temporary (:sc unsigned-reg :from (:argument 0)) temp)
737 (inst mov temp result)
739 (inst and result #x55555555)
740 (inst and temp #x55555555)
741 (inst add result temp)
743 (inst mov temp result)
745 (inst and result #x33333333)
746 (inst and temp #x33333333)
747 (inst add result temp)
749 (inst mov temp result)
751 (inst and result #x0f0f0f0f)
752 (inst and temp #x0f0f0f0f)
753 (inst add result temp)
755 (inst mov temp result)
757 (inst and result #x00ff00ff)
758 (inst and temp #x00ff00ff)
759 (inst add result temp)
761 (inst mov temp result)
763 (inst and result #x0000ffff)
764 (inst and temp #x0000ffff)
765 (inst add result temp)))
769 ;;;; binary conditional VOPs
771 (define-vop (fast-conditional)
776 (:policy :fast-safe))
778 (define-vop (fast-conditional/fixnum fast-conditional)
779 (:args (x :scs (any-reg)
780 :load-if (not (and (sc-is x control-stack)
782 (y :scs (any-reg control-stack)))
783 (:arg-types tagged-num tagged-num)
784 (:note "inline fixnum comparison"))
786 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
787 (:args (x :scs (any-reg control-stack)))
788 (:arg-types tagged-num (:constant (signed-byte 30)))
789 (:info target not-p y))
791 (define-vop (fast-conditional/signed fast-conditional)
792 (:args (x :scs (signed-reg)
793 :load-if (not (and (sc-is x signed-stack)
794 (sc-is y signed-reg))))
795 (y :scs (signed-reg signed-stack)))
796 (:arg-types signed-num signed-num)
797 (:note "inline (signed-byte 32) comparison"))
799 (define-vop (fast-conditional-c/signed fast-conditional/signed)
800 (:args (x :scs (signed-reg signed-stack)))
801 (:arg-types signed-num (:constant (signed-byte 32)))
802 (:info target not-p y))
804 (define-vop (fast-conditional/unsigned fast-conditional)
805 (:args (x :scs (unsigned-reg)
806 :load-if (not (and (sc-is x unsigned-stack)
807 (sc-is y unsigned-reg))))
808 (y :scs (unsigned-reg unsigned-stack)))
809 (:arg-types unsigned-num unsigned-num)
810 (:note "inline (unsigned-byte 32) comparison"))
812 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
813 (:args (x :scs (unsigned-reg unsigned-stack)))
814 (:arg-types unsigned-num (:constant (unsigned-byte 32)))
815 (:info target not-p y))
818 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
821 #'(lambda (suffix cost signed)
822 `(define-vop (;; FIXME: These could be done more
823 ;; cleanly with SYMBOLICATE.
824 ,(intern (format nil "~:@(FAST-IF-~A~A~)"
827 (format nil "~:@(FAST-CONDITIONAL~A~)"
832 ,(if (eq suffix '-c/fixnum)
843 '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
845 '(t t t t nil nil)))))
847 (define-conditional-vop < :l :b :ge :ae)
848 (define-conditional-vop > :g :a :le :be))
850 (define-vop (fast-if-eql/signed fast-conditional/signed)
854 (inst jmp (if not-p :ne :e) target)))
856 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
859 (cond ((and (sc-is x signed-reg) (zerop y))
860 (inst test x x)) ; smaller instruction
863 (inst jmp (if not-p :ne :e) target)))
865 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
869 (inst jmp (if not-p :ne :e) target)))
871 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
874 (cond ((and (sc-is x unsigned-reg) (zerop y))
875 (inst test x x)) ; smaller instruction
878 (inst jmp (if not-p :ne :e) target)))
880 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
883 ;;; These versions specify a fixnum restriction on their first arg. We have
884 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
885 ;;; the first arg and a higher cost. The reason for doing this is to prevent
886 ;;; fixnum specific operations from being used on word integers, spuriously
887 ;;; consing the argument.
889 (define-vop (fast-eql/fixnum fast-conditional)
890 (:args (x :scs (any-reg)
891 :load-if (not (and (sc-is x control-stack)
893 (y :scs (any-reg control-stack)))
894 (:arg-types tagged-num tagged-num)
895 (:note "inline fixnum comparison")
899 (inst jmp (if not-p :ne :e) target)))
900 (define-vop (generic-eql/fixnum fast-eql/fixnum)
901 (:args (x :scs (any-reg descriptor-reg)
902 :load-if (not (and (sc-is x control-stack)
904 (y :scs (any-reg control-stack)))
905 (:arg-types * tagged-num)
908 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
909 (:args (x :scs (any-reg control-stack)))
910 (:arg-types tagged-num (:constant (signed-byte 30)))
911 (:info target not-p y)
914 (cond ((and (sc-is x any-reg) (zerop y))
915 (inst test x x)) ; smaller instruction
917 (inst cmp x (fixnumize y))))
918 (inst jmp (if not-p :ne :e) target)))
919 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
920 (:args (x :scs (any-reg descriptor-reg control-stack)))
921 (:arg-types * (:constant (signed-byte 30)))
924 ;;;; 32-bit logical operations
926 (define-vop (merge-bits)
927 (:translate merge-bits)
928 (:args (shift :scs (signed-reg unsigned-reg) :target ecx)
929 (prev :scs (unsigned-reg) :target result)
930 (next :scs (unsigned-reg)))
931 (:arg-types tagged-num unsigned-num unsigned-num)
932 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 0)) ecx)
933 (:results (result :scs (unsigned-reg) :from (:argument 1)))
934 (:result-types unsigned-num)
939 (inst shrd result next :cl)))
941 (define-vop (32bit-logical)
942 (:args (x :scs (unsigned-reg) :target r
943 :load-if (not (and (sc-is x unsigned-stack)
944 (sc-is r unsigned-stack)
946 (y :scs (unsigned-reg)
947 :load-if (or (not (sc-is y unsigned-stack))
948 (and (sc-is x unsigned-stack)
949 (sc-is y unsigned-stack)
951 (:arg-types unsigned-num unsigned-num)
952 (:results (r :scs (unsigned-reg)
954 :load-if (not (and (sc-is x unsigned-stack)
955 (sc-is r unsigned-stack)
957 (:result-types unsigned-num)
958 (:policy :fast-safe))
960 (define-vop (32bit-logical-not)
961 (:translate 32bit-logical-not)
962 (:args (x :scs (unsigned-reg) :target r
963 :load-if (not (and (sc-is x unsigned-stack)
964 (sc-is r unsigned-stack)
966 (:arg-types unsigned-num)
967 (:results (r :scs (unsigned-reg)
968 :load-if (not (and (sc-is x unsigned-stack)
969 (sc-is r unsigned-stack)
971 (:result-types unsigned-num)
977 (define-vop (32bit-logical-and 32bit-logical)
978 (:translate 32bit-logical-and)
983 (def-source-transform 32bit-logical-nand (x y)
984 `(32bit-logical-not (32bit-logical-and ,x ,y)))
986 (define-vop (32bit-logical-or 32bit-logical)
987 (:translate 32bit-logical-or)
992 (def-source-transform 32bit-logical-nor (x y)
993 `(32bit-logical-not (32bit-logical-or ,x ,y)))
995 (define-vop (32bit-logical-xor 32bit-logical)
996 (:translate 32bit-logical-xor)
1001 (def-source-transform 32bit-logical-eqv (x y)
1002 `(32bit-logical-not (32bit-logical-xor ,x ,y)))
1004 (def-source-transform 32bit-logical-orc1 (x y)
1005 `(32bit-logical-or (32bit-logical-not ,x) ,y))
1007 (def-source-transform 32bit-logical-orc2 (x y)
1008 `(32bit-logical-or ,x (32bit-logical-not ,y)))
1010 (def-source-transform 32bit-logical-andc1 (x y)
1011 `(32bit-logical-and (32bit-logical-not ,x) ,y))
1013 (def-source-transform 32bit-logical-andc2 (x y)
1014 `(32bit-logical-and ,x (32bit-logical-not ,y)))
1016 ;;; Only the lower 5 bits of the shift amount are significant.
1017 (define-vop (shift-towards-someplace)
1018 (:policy :fast-safe)
1019 (:args (num :scs (unsigned-reg) :target r)
1020 (amount :scs (signed-reg) :target ecx))
1021 (:arg-types unsigned-num tagged-num)
1022 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
1023 (:results (r :scs (unsigned-reg) :from (:argument 0)))
1024 (:result-types unsigned-num))
1026 (define-vop (shift-towards-start shift-towards-someplace)
1027 (:translate shift-towards-start)
1028 (:note "SHIFT-TOWARDS-START")
1034 (define-vop (shift-towards-end shift-towards-someplace)
1035 (:translate shift-towards-end)
1036 (:note "SHIFT-TOWARDS-END")
1044 (define-vop (bignum-length get-header-data)
1045 (:translate sb!bignum::%bignum-length)
1046 (:policy :fast-safe))
1048 (define-vop (bignum-set-length set-header-data)
1049 (:translate sb!bignum::%bignum-set-length)
1050 (:policy :fast-safe))
1052 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type
1053 (unsigned-reg) unsigned-num sb!bignum::%bignum-ref)
1055 (define-full-setter bignum-set * bignum-digits-offset other-pointer-type
1056 (unsigned-reg) unsigned-num sb!bignum::%bignum-set)
1058 (define-vop (digit-0-or-plus)
1059 (:translate sb!bignum::%digit-0-or-plusp)
1060 (:policy :fast-safe)
1061 (:args (digit :scs (unsigned-reg)))
1062 (:arg-types unsigned-num)
1064 (:info target not-p)
1066 (inst or digit digit)
1067 (inst jmp (if not-p :s :ns) target)))
1070 ;;; For add and sub with carry the sc of carry argument is any-reg so
1071 ;;; the it may be passed as a fixnum or word and thus may be 0, 1, or
1072 ;;; 4. This is easy to deal with and may save a fixnum-word
1074 (define-vop (add-w/carry)
1075 (:translate sb!bignum::%add-with-carry)
1076 (:policy :fast-safe)
1077 (:args (a :scs (unsigned-reg) :target result)
1078 (b :scs (unsigned-reg unsigned-stack) :to :eval)
1079 (c :scs (any-reg) :target temp))
1080 (:arg-types unsigned-num unsigned-num positive-fixnum)
1081 (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
1082 (:results (result :scs (unsigned-reg) :from (:argument 0))
1083 (carry :scs (unsigned-reg)))
1084 (:result-types unsigned-num positive-fixnum)
1088 (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
1091 (inst adc carry carry)))
1093 ;;; Note: the borrow is the oppostite of the x86 convention - 1 for no
1094 ;;; borrow and 0 for a borrow.
1095 (define-vop (sub-w/borrow)
1096 (:translate sb!bignum::%subtract-with-borrow)
1097 (:policy :fast-safe)
1098 (:args (a :scs (unsigned-reg) :to :eval :target result)
1099 (b :scs (unsigned-reg unsigned-stack) :to :result)
1100 (c :scs (any-reg control-stack)))
1101 (:arg-types unsigned-num unsigned-num positive-fixnum)
1102 (:results (result :scs (unsigned-reg) :from :eval)
1103 (borrow :scs (unsigned-reg)))
1104 (:result-types unsigned-num positive-fixnum)
1106 (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
1110 (inst adc borrow borrow)
1111 (inst xor borrow 1)))
1114 (define-vop (bignum-mult-and-add-3-arg)
1115 (:translate sb!bignum::%multiply-and-add)
1116 (:policy :fast-safe)
1117 (:args (x :scs (unsigned-reg) :target eax)
1118 (y :scs (unsigned-reg unsigned-stack))
1119 (carry-in :scs (unsigned-reg unsigned-stack)))
1120 (:arg-types unsigned-num unsigned-num unsigned-num)
1121 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1122 :to (:result 1) :target lo) eax)
1123 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1124 :to (:result 0) :target hi) edx)
1125 (:results (hi :scs (unsigned-reg))
1126 (lo :scs (unsigned-reg)))
1127 (:result-types unsigned-num unsigned-num)
1131 (inst add eax carry-in)
1136 (define-vop (bignum-mult-and-add-4-arg)
1137 (:translate sb!bignum::%multiply-and-add)
1138 (:policy :fast-safe)
1139 (:args (x :scs (unsigned-reg) :target eax)
1140 (y :scs (unsigned-reg unsigned-stack))
1141 (prev :scs (unsigned-reg unsigned-stack))
1142 (carry-in :scs (unsigned-reg unsigned-stack)))
1143 (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1144 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1145 :to (:result 1) :target lo) eax)
1146 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1147 :to (:result 0) :target hi) edx)
1148 (:results (hi :scs (unsigned-reg))
1149 (lo :scs (unsigned-reg)))
1150 (:result-types unsigned-num unsigned-num)
1156 (inst add eax carry-in)
1162 (define-vop (bignum-mult)
1163 (:translate sb!bignum::%multiply)
1164 (:policy :fast-safe)
1165 (:args (x :scs (unsigned-reg) :target eax)
1166 (y :scs (unsigned-reg unsigned-stack)))
1167 (:arg-types unsigned-num unsigned-num)
1168 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1169 :to (:result 1) :target lo) eax)
1170 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1171 :to (:result 0) :target hi) edx)
1172 (:results (hi :scs (unsigned-reg))
1173 (lo :scs (unsigned-reg)))
1174 (:result-types unsigned-num unsigned-num)
1181 (define-vop (bignum-lognot)
1182 (:translate sb!bignum::%lognot)
1183 (:policy :fast-safe)
1184 (:args (x :scs (unsigned-reg unsigned-stack) :target r))
1185 (:arg-types unsigned-num)
1186 (:results (r :scs (unsigned-reg)
1187 :load-if (not (location= x r))))
1188 (:result-types unsigned-num)
1193 (define-vop (fixnum-to-digit)
1194 (:translate sb!bignum::%fixnum-to-digit)
1195 (:policy :fast-safe)
1196 (:args (fixnum :scs (any-reg control-stack) :target digit))
1197 (:arg-types tagged-num)
1198 (:results (digit :scs (unsigned-reg)
1199 :load-if (not (and (sc-is fixnum control-stack)
1200 (sc-is digit unsigned-stack)
1201 (location= fixnum digit)))))
1202 (:result-types unsigned-num)
1205 (inst sar digit 2)))
1207 (define-vop (bignum-floor)
1208 (:translate sb!bignum::%floor)
1209 (:policy :fast-safe)
1210 (:args (div-high :scs (unsigned-reg) :target edx)
1211 (div-low :scs (unsigned-reg) :target eax)
1212 (divisor :scs (unsigned-reg unsigned-stack)))
1213 (:arg-types unsigned-num unsigned-num unsigned-num)
1214 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
1215 :to (:result 0) :target quo) eax)
1216 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
1217 :to (:result 1) :target rem) edx)
1218 (:results (quo :scs (unsigned-reg))
1219 (rem :scs (unsigned-reg)))
1220 (:result-types unsigned-num unsigned-num)
1224 (inst div eax divisor)
1228 (define-vop (signify-digit)
1229 (:translate sb!bignum::%fixnum-digit-with-correct-sign)
1230 (:policy :fast-safe)
1231 (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
1232 (:arg-types unsigned-num)
1233 (:results (res :scs (any-reg signed-reg)
1234 :load-if (not (and (sc-is digit unsigned-stack)
1235 (sc-is res control-stack signed-stack)
1236 (location= digit res)))))
1237 (:result-types signed-num)
1240 (when (sc-is res any-reg control-stack)
1243 (define-vop (digit-ashr)
1244 (:translate sb!bignum::%ashr)
1245 (:policy :fast-safe)
1246 (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
1247 (count :scs (unsigned-reg) :target ecx))
1248 (:arg-types unsigned-num positive-fixnum)
1249 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
1250 (:results (result :scs (unsigned-reg) :from (:argument 0)
1251 :load-if (not (and (sc-is result unsigned-stack)
1252 (location= digit result)))))
1253 (:result-types unsigned-num)
1257 (inst sar result :cl)))
1259 (define-vop (digit-lshr digit-ashr)
1260 (:translate sb!bignum::%digit-logical-shift-right)
1264 (inst shr result :cl)))
1266 (define-vop (digit-ashl digit-ashr)
1267 (:translate sb!bignum::%ashl)
1271 (inst shl result :cl)))
1273 ;;;; static functions
1275 (define-static-function two-arg-/ (x y) :translate /)
1277 (define-static-function two-arg-gcd (x y) :translate gcd)
1278 (define-static-function two-arg-lcm (x y) :translate lcm)
1280 (define-static-function two-arg-and (x y) :translate logand)
1281 (define-static-function two-arg-ior (x y) :translate logior)
1282 (define-static-function two-arg-xor (x y) :translate logxor)
1285 ;;; Support for the Mersenne Twister, MT19937, random number generator
1286 ;;; due to Matsumoto and Nishimura.
1288 ;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A
1289 ;;; 623-dimensionally equidistributed uniform pseudorandom number
1290 ;;; generator.", ACM Transactions on Modeling and Computer Simulation,
1291 ;;; 1997, to appear.
1294 ;;; 0-1: Constant matrix A. [0, #x9908b0df] (not used here)
1295 ;;; 2: Index; init. to 1.
1297 (defknown random-mt19937 ((simple-array (unsigned-byte 32) (*)))
1298 (unsigned-byte 32) ())
1299 (define-vop (random-mt19937)
1300 (:policy :fast-safe)
1301 (:translate random-mt19937)
1302 (:args (state :scs (descriptor-reg) :to :result))
1303 (:arg-types simple-array-unsigned-byte-32)
1304 (:temporary (:sc unsigned-reg :from (:eval 0) :to :result) k)
1305 (:temporary (:sc unsigned-reg :offset eax-offset
1306 :from (:eval 0) :to :result) tmp)
1307 (:results (y :scs (unsigned-reg) :from (:eval 0)))
1308 (:result-types unsigned-num)
1310 (inst mov k (make-ea :dword :base state
1311 :disp (- (* (+ 2 sb!vm:vector-data-offset)
1313 sb!vm:other-pointer-type)))
1315 (inst jmp :ne no-update)
1316 (inst mov tmp state) ; The state is passed in EAX.
1317 (inst call (make-fixup 'random-mt19937-update :assembly-routine))
1318 ;; Restore k, and set to 0.
1322 (inst mov y (make-ea :dword :base state :index k :scale 4
1323 :disp (- (* (+ 3 sb!vm:vector-data-offset)
1325 sb!vm:other-pointer-type)))
1328 (inst xor y (make-ea :dword :base state :index k :scale 4
1329 :disp (- (* (+ 3 sb!vm:vector-data-offset)
1331 sb!vm:other-pointer-type)))
1332 ;; y ^= (y << 7) & #x9d2c5680
1336 (inst mov (make-ea :dword :base state
1337 :disp (- (* (+ 2 sb!vm:vector-data-offset)
1339 sb!vm:other-pointer-type))
1341 (inst and tmp #x9d2c5680)
1343 ;; y ^= (y << 15) & #xefc60000
1346 (inst and tmp #xefc60000)