1 ;;;; the VM definition of arithmetic VOPs for the x86-64
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
15 ;; A fixnum that can be represented in tagged form by a signed 32-bit
16 ;; value and that can therefore be used as an immediate argument of
17 ;; arithmetic machine instructions.
18 (deftype short-tagged-num () '(signed-byte #.(- 32 n-fixnum-tag-bits)))
22 (define-vop (fast-safe-arith-op)
27 (define-vop (fixnum-unop fast-safe-arith-op)
28 (:args (x :scs (any-reg) :target res))
29 (:results (res :scs (any-reg)))
30 (:note "inline fixnum arithmetic")
31 (:arg-types tagged-num)
32 (:result-types tagged-num))
34 (define-vop (signed-unop fast-safe-arith-op)
35 (:args (x :scs (signed-reg) :target res))
36 (:results (res :scs (signed-reg)))
37 (:note "inline (signed-byte 64) arithmetic")
38 (:arg-types signed-num)
39 (:result-types signed-num))
41 (define-vop (fast-negate/fixnum fixnum-unop)
47 (define-vop (fast-negate/signed signed-unop)
53 (define-vop (fast-lognot/fixnum fixnum-unop)
57 (inst xor res (fixnumize -1))))
59 (define-vop (fast-lognot/signed signed-unop)
65 ;;;; binary fixnum operations
67 ;;; Assume that any constant operand is the second arg...
69 (define-vop (fast-fixnum-binop fast-safe-arith-op)
70 (:args (x :target r :scs (any-reg)
71 :load-if (not (and (sc-is x control-stack)
73 (sc-is r control-stack)
75 (y :scs (any-reg control-stack)))
76 (:arg-types tagged-num tagged-num)
77 (:results (r :scs (any-reg) :from (:argument 0)
78 :load-if (not (and (sc-is x control-stack)
80 (sc-is r control-stack)
82 (:result-types tagged-num)
83 (:note "inline fixnum arithmetic"))
85 (define-vop (fast-unsigned-binop fast-safe-arith-op)
86 (:args (x :target r :scs (unsigned-reg)
87 :load-if (not (and (sc-is x unsigned-stack)
88 (sc-is y unsigned-reg)
89 (sc-is r unsigned-stack)
91 (y :scs (unsigned-reg unsigned-stack)))
92 (:arg-types unsigned-num unsigned-num)
93 (:results (r :scs (unsigned-reg) :from (:argument 0)
94 :load-if (not (and (sc-is x unsigned-stack)
95 (sc-is y unsigned-reg)
96 (sc-is r unsigned-stack)
98 (:result-types unsigned-num)
99 (:note "inline (unsigned-byte 64) arithmetic"))
101 (define-vop (fast-signed-binop fast-safe-arith-op)
102 (:args (x :target r :scs (signed-reg)
103 :load-if (not (and (sc-is x signed-stack)
105 (sc-is r signed-stack)
107 (y :scs (signed-reg signed-stack)))
108 (:arg-types signed-num signed-num)
109 (:results (r :scs (signed-reg) :from (:argument 0)
110 :load-if (not (and (sc-is x signed-stack)
112 (sc-is r signed-stack)
114 (:result-types signed-num)
115 (:note "inline (signed-byte 64) arithmetic"))
117 (define-vop (fast-fixnum-binop-c fast-safe-arith-op)
118 (:args (x :target r :scs (any-reg)
119 :load-if (or (not (typep y 'short-tagged-num))
120 (not (sc-is x any-reg control-stack)))))
122 (:arg-types tagged-num (:constant fixnum))
123 (:results (r :scs (any-reg)
124 :load-if (or (not (location= x r))
125 (not (typep y 'short-tagged-num)))))
126 (:result-types tagged-num)
127 (:note "inline fixnum arithmetic"))
129 (define-vop (fast-unsigned-binop-c fast-safe-arith-op)
130 (:args (x :target r :scs (unsigned-reg)
131 :load-if (or (not (typep y '(unsigned-byte 31)))
132 (not (sc-is x unsigned-reg unsigned-stack)))))
134 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
135 (:results (r :scs (unsigned-reg)
136 :load-if (or (not (location= x r))
137 (not (typep y '(unsigned-byte 31))))))
138 (:result-types unsigned-num)
139 (:note "inline (unsigned-byte 64) arithmetic"))
141 (define-vop (fast-signed-binop-c fast-safe-arith-op)
142 (:args (x :target r :scs (signed-reg)
143 :load-if (or (not (typep y '(signed-byte 32)))
144 (not (sc-is x signed-reg signed-stack)))))
146 (:arg-types signed-num (:constant (signed-byte 64)))
147 (:results (r :scs (signed-reg)
148 :load-if (or (not (location= x r))
149 (not (typep y '(signed-byte 32))))))
150 (:result-types signed-num)
151 (:note "inline (signed-byte 64) arithmetic"))
153 (macrolet ((define-binop (translate untagged-penalty op)
155 (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
157 (:translate ,translate)
161 (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
163 (:translate ,translate)
166 (inst ,op r (if (typep y 'short-tagged-num)
168 (register-inline-constant :qword (fixnumize y))))))
169 (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
171 (:translate ,translate)
172 (:generator ,(1+ untagged-penalty)
175 (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
177 (:translate ,translate)
178 (:generator ,untagged-penalty
180 (inst ,op r (if (typep y '(signed-byte 32))
182 (register-inline-constant :qword y)))))
183 (define-vop (,(symbolicate "FAST-"
185 "/UNSIGNED=>UNSIGNED")
187 (:translate ,translate)
188 (:generator ,(1+ untagged-penalty)
191 (define-vop (,(symbolicate 'fast-
193 '-c/unsigned=>unsigned)
194 fast-unsigned-binop-c)
195 (:translate ,translate)
196 (:generator ,untagged-penalty
198 (inst ,op r (if (typep y '(unsigned-byte 31))
200 (register-inline-constant :qword y))))))))
202 ;;(define-binop + 4 add)
203 (define-binop - 4 sub)
204 (define-binop logand 2 and)
205 (define-binop logior 2 or)
206 (define-binop logxor 2 xor))
208 ;;; Special handling of add on the x86; can use lea to avoid a
209 ;;; register load, otherwise it uses add.
210 (define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op)
212 (:args (x :scs (any-reg) :target r
213 :load-if (not (and (sc-is x control-stack)
215 (sc-is r control-stack)
217 (y :scs (any-reg control-stack)))
218 (:arg-types tagged-num tagged-num)
219 (:results (r :scs (any-reg) :from (:argument 0)
220 :load-if (not (and (sc-is x control-stack)
222 (sc-is r control-stack)
224 (:result-types tagged-num)
225 (:note "inline fixnum arithmetic")
227 (cond ((and (sc-is x any-reg) (sc-is y any-reg) (sc-is r any-reg)
228 (not (location= x r)))
229 (inst lea r (make-ea :qword :base x :index y :scale 1)))
234 (define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op)
236 (:args (x :target r :scs (any-reg)
237 :load-if (or (not (typep y 'short-tagged-num))
238 (not (sc-is x any-reg control-stack)))))
240 (:arg-types tagged-num (:constant fixnum))
241 (:results (r :scs (any-reg)
242 :load-if (or (not (location= x r))
243 (not (typep y 'short-tagged-num)))))
244 (:result-types tagged-num)
245 (:note "inline fixnum arithmetic")
247 (cond ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r))
248 (typep y 'short-tagged-num))
249 (inst lea r (make-ea :qword :base x :disp (fixnumize y))))
250 ((typep y 'short-tagged-num)
252 (inst add r (fixnumize y)))
255 (inst add r (register-inline-constant :qword (fixnumize y)))))))
257 (define-vop (fast-+/signed=>signed fast-safe-arith-op)
259 (:args (x :scs (signed-reg) :target r
260 :load-if (not (and (sc-is x signed-stack)
262 (sc-is r signed-stack)
264 (y :scs (signed-reg signed-stack)))
265 (:arg-types signed-num signed-num)
266 (:results (r :scs (signed-reg) :from (:argument 0)
267 :load-if (not (and (sc-is x signed-stack)
270 (:result-types signed-num)
271 (:note "inline (signed-byte 64) arithmetic")
273 (cond ((and (sc-is x signed-reg) (sc-is y signed-reg) (sc-is r signed-reg)
274 (not (location= x r)))
275 (inst lea r (make-ea :qword :base x :index y :scale 1)))
281 ;;;; Special logand cases: (logand signed unsigned) => unsigned
283 (define-vop (fast-logand/signed-unsigned=>unsigned
284 fast-logand/unsigned=>unsigned)
285 (:args (x :target r :scs (signed-reg)
286 :load-if (not (and (sc-is x signed-stack)
287 (sc-is y unsigned-reg)
288 (sc-is r unsigned-stack)
290 (y :scs (unsigned-reg unsigned-stack)))
291 (:arg-types signed-num unsigned-num))
293 (define-vop (fast-logand-c/signed-unsigned=>unsigned
294 fast-logand-c/unsigned=>unsigned)
295 (:args (x :target r :scs (signed-reg)
296 :load-if (or (not (typep y '(unsigned-byte 31)))
297 (not (sc-is r signed-reg signed-stack)))))
298 (:arg-types signed-num (:constant (unsigned-byte 64))))
300 (define-vop (fast-logand/unsigned-signed=>unsigned
301 fast-logand/unsigned=>unsigned)
302 (:args (x :target r :scs (unsigned-reg)
303 :load-if (not (and (sc-is x unsigned-stack)
305 (sc-is r unsigned-stack)
307 (y :scs (signed-reg signed-stack)))
308 (:arg-types unsigned-num signed-num))
311 (define-vop (fast-+-c/signed=>signed fast-safe-arith-op)
313 (:args (x :target r :scs (signed-reg)
314 :load-if (or (not (typep y '(signed-byte 32)))
315 (not (sc-is r signed-reg signed-stack)))))
317 (:arg-types signed-num (:constant (signed-byte 64)))
318 (:results (r :scs (signed-reg)
319 :load-if (or (not (location= x r))
320 (not (typep y '(signed-byte 32))))))
321 (:result-types signed-num)
322 (:note "inline (signed-byte 64) arithmetic")
324 (cond ((and (sc-is x signed-reg) (sc-is r signed-reg)
325 (not (location= x r))
326 (typep y '(signed-byte 32)))
327 (inst lea r (make-ea :qword :base x :disp y)))
332 ((typep y '(signed-byte 32))
335 (inst add r (register-inline-constant :qword y))))))))
337 (define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op)
339 (:args (x :scs (unsigned-reg) :target r
340 :load-if (not (and (sc-is x unsigned-stack)
341 (sc-is y unsigned-reg)
342 (sc-is r unsigned-stack)
344 (y :scs (unsigned-reg unsigned-stack)))
345 (:arg-types unsigned-num unsigned-num)
346 (:results (r :scs (unsigned-reg) :from (:argument 0)
347 :load-if (not (and (sc-is x unsigned-stack)
348 (sc-is y unsigned-reg)
349 (sc-is r unsigned-stack)
351 (:result-types unsigned-num)
352 (:note "inline (unsigned-byte 64) arithmetic")
354 (cond ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg)
355 (sc-is r unsigned-reg) (not (location= x r)))
356 (inst lea r (make-ea :qword :base x :index y :scale 1)))
361 (define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op)
363 (:args (x :target r :scs (unsigned-reg)
364 :load-if (or (not (typep y '(unsigned-byte 31)))
365 (not (sc-is x unsigned-reg unsigned-stack)))))
367 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
368 (:results (r :scs (unsigned-reg)
369 :load-if (or (not (location= x r))
370 (not (typep y '(unsigned-byte 31))))))
371 (:result-types unsigned-num)
372 (:note "inline (unsigned-byte 64) arithmetic")
374 (cond ((and (sc-is x unsigned-reg) (sc-is r unsigned-reg)
375 (not (location= x r))
376 (typep y '(unsigned-byte 31)))
377 (inst lea r (make-ea :qword :base x :disp y)))
382 ((typep y '(unsigned-byte 31))
385 (inst add r (register-inline-constant :qword y))))))))
387 ;;;; multiplication and division
389 (define-vop (fast-*/fixnum=>fixnum fast-safe-arith-op)
391 ;; We need different loading characteristics.
392 (:args (x :scs (any-reg) :target r)
393 (y :scs (any-reg control-stack)))
394 (:arg-types tagged-num tagged-num)
395 (:results (r :scs (any-reg) :from (:argument 0)))
396 (:result-types tagged-num)
397 (:note "inline fixnum arithmetic")
400 (inst sar r n-fixnum-tag-bits)
403 (define-vop (fast-*-c/fixnum=>fixnum fast-safe-arith-op)
405 ;; We need different loading characteristics.
406 (:args (x :scs (any-reg)
407 :load-if (or (not (typep y '(signed-byte 32)))
408 (not (sc-is x any-reg control-stack)))))
410 (:arg-types tagged-num (:constant fixnum))
411 (:results (r :scs (any-reg)))
412 (:result-types tagged-num)
413 (:note "inline fixnum arithmetic")
415 (cond ((typep y '(signed-byte 32))
419 (inst imul r (register-inline-constant :qword y))))))
421 (define-vop (fast-*/signed=>signed fast-safe-arith-op)
423 ;; We need different loading characteristics.
424 (:args (x :scs (signed-reg) :target r)
425 (y :scs (signed-reg signed-stack)))
426 (:arg-types signed-num signed-num)
427 (:results (r :scs (signed-reg) :from (:argument 0)))
428 (:result-types signed-num)
429 (:note "inline (signed-byte 64) arithmetic")
434 (define-vop (fast-*-c/signed=>signed fast-safe-arith-op)
436 ;; We need different loading characteristics.
437 (:args (x :scs (signed-reg)
438 :load-if (or (not (typep y '(signed-byte 32)))
439 (not (sc-is x signed-reg signed-stack)))))
441 (:arg-types signed-num (:constant (signed-byte 64)))
442 (:results (r :scs (signed-reg)))
443 (:result-types signed-num)
444 (:note "inline (signed-byte 64) arithmetic")
446 (cond ((typep y '(signed-byte 32))
450 (inst imul r (register-inline-constant :qword y))))))
452 (define-vop (fast-*/unsigned=>unsigned fast-safe-arith-op)
454 (:args (x :scs (unsigned-reg) :target eax)
455 (y :scs (unsigned-reg unsigned-stack)))
456 (:arg-types unsigned-num unsigned-num)
457 (:temporary (:sc unsigned-reg :offset eax-offset :target r
458 :from (:argument 0) :to :result) eax)
459 (:temporary (:sc unsigned-reg :offset edx-offset
460 :from :eval :to :result) edx)
462 (:results (r :scs (unsigned-reg)))
463 (:result-types unsigned-num)
464 (:note "inline (unsigned-byte 64) arithmetic")
466 (:save-p :compute-only)
472 (define-vop (fast-*-c/unsigned=>unsigned fast-safe-arith-op)
474 (:args (x :scs (unsigned-reg) :target eax))
476 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
477 (:temporary (:sc unsigned-reg :offset eax-offset :target r
478 :from (:argument 0) :to :result) eax)
479 (:temporary (:sc unsigned-reg :offset edx-offset
480 :from :eval :to :result) edx)
482 (:results (r :scs (unsigned-reg)))
483 (:result-types unsigned-num)
484 (:note "inline (unsigned-byte 64) arithmetic")
486 (:save-p :compute-only)
489 (inst mul eax (register-inline-constant :qword y))
493 (define-vop (fast-truncate/fixnum=>fixnum fast-safe-arith-op)
494 (:translate truncate)
495 (:args (x :scs (any-reg) :target eax)
496 (y :scs (any-reg control-stack)))
497 (:arg-types tagged-num tagged-num)
498 (:temporary (:sc signed-reg :offset eax-offset :target quo
499 :from (:argument 0) :to (:result 0)) eax)
500 (:temporary (:sc unsigned-reg :offset edx-offset :target rem
501 :from (:argument 0) :to (:result 1)) edx)
502 (:results (quo :scs (any-reg))
503 (rem :scs (any-reg)))
504 (:result-types tagged-num tagged-num)
505 (:note "inline fixnum arithmetic")
507 (:save-p :compute-only)
509 (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
510 (if (sc-is y any-reg)
511 (inst test y y) ; smaller instruction
517 (if (location= quo eax)
518 (inst shl eax n-fixnum-tag-bits)
519 (if (= n-fixnum-tag-bits 1)
520 (inst lea quo (make-ea :qword :base eax :index eax))
521 (inst lea quo (make-ea :qword :index eax
522 :scale (ash 1 n-fixnum-tag-bits)))))
525 (define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
526 (:translate truncate)
527 (:args (x :scs (any-reg) :target eax))
529 (:arg-types tagged-num (:constant fixnum))
530 (:temporary (:sc signed-reg :offset eax-offset :target quo
531 :from :argument :to (:result 0)) eax)
532 (:temporary (:sc any-reg :offset edx-offset :target rem
533 :from :eval :to (:result 1)) edx)
534 (:temporary (:sc any-reg :from :eval :to :result) y-arg)
535 (:results (quo :scs (any-reg))
536 (rem :scs (any-reg)))
537 (:result-types tagged-num tagged-num)
538 (:note "inline fixnum arithmetic")
540 (:save-p :compute-only)
544 (if (typep y 'short-tagged-num)
545 (inst mov y-arg (fixnumize y))
546 (setf y-arg (register-inline-constant :qword (fixnumize y))))
547 (inst idiv eax y-arg)
548 (if (location= quo eax)
549 (inst shl eax n-fixnum-tag-bits)
550 (if (= n-fixnum-tag-bits 1)
551 (inst lea quo (make-ea :qword :base eax :index eax))
552 (inst lea quo (make-ea :qword :index eax
553 :scale (ash 1 n-fixnum-tag-bits)))))
556 (define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
557 (:translate truncate)
558 (:args (x :scs (unsigned-reg) :target eax)
559 (y :scs (unsigned-reg signed-stack)))
560 (:arg-types unsigned-num unsigned-num)
561 (:temporary (:sc unsigned-reg :offset eax-offset :target quo
562 :from (:argument 0) :to (:result 0)) eax)
563 (:temporary (:sc unsigned-reg :offset edx-offset :target rem
564 :from (:argument 0) :to (:result 1)) edx)
565 (:results (quo :scs (unsigned-reg))
566 (rem :scs (unsigned-reg)))
567 (:result-types unsigned-num unsigned-num)
568 (:note "inline (unsigned-byte 64) arithmetic")
570 (:save-p :compute-only)
572 (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
573 (if (sc-is y unsigned-reg)
574 (inst test y y) ; smaller instruction
583 (define-vop (fast-truncate-c/unsigned=>unsigned fast-safe-arith-op)
584 (:translate truncate)
585 (:args (x :scs (unsigned-reg) :target eax))
587 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
588 (:temporary (:sc unsigned-reg :offset eax-offset :target quo
589 :from :argument :to (:result 0)) eax)
590 (:temporary (:sc unsigned-reg :offset edx-offset :target rem
591 :from :eval :to (:result 1)) edx)
592 (:temporary (:sc unsigned-reg :from :eval :to :result) y-arg)
593 (:results (quo :scs (unsigned-reg))
594 (rem :scs (unsigned-reg)))
595 (:result-types unsigned-num unsigned-num)
596 (:note "inline (unsigned-byte 64) arithmetic")
598 (:save-p :compute-only)
602 (if (typep y '(unsigned-byte 31))
604 (setf y-arg (register-inline-constant :qword y)))
609 (define-vop (fast-truncate/signed=>signed fast-safe-arith-op)
610 (:translate truncate)
611 (:args (x :scs (signed-reg) :target eax)
612 (y :scs (signed-reg signed-stack)))
613 (:arg-types signed-num signed-num)
614 (:temporary (:sc signed-reg :offset eax-offset :target quo
615 :from (:argument 0) :to (:result 0)) eax)
616 (:temporary (:sc signed-reg :offset edx-offset :target rem
617 :from (:argument 0) :to (:result 1)) edx)
618 (:results (quo :scs (signed-reg))
619 (rem :scs (signed-reg)))
620 (:result-types signed-num signed-num)
621 (:note "inline (signed-byte 64) arithmetic")
623 (:save-p :compute-only)
625 (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
626 (if (sc-is y signed-reg)
627 (inst test y y) ; smaller instruction
636 (define-vop (fast-truncate-c/signed=>signed fast-safe-arith-op)
637 (:translate truncate)
638 (:args (x :scs (signed-reg) :target eax))
640 (:arg-types signed-num (:constant (signed-byte 64)))
641 (:temporary (:sc signed-reg :offset eax-offset :target quo
642 :from :argument :to (:result 0)) eax)
643 (:temporary (:sc signed-reg :offset edx-offset :target rem
644 :from :eval :to (:result 1)) edx)
645 (:temporary (:sc signed-reg :from :eval :to :result) y-arg)
646 (:results (quo :scs (signed-reg))
647 (rem :scs (signed-reg)))
648 (:result-types signed-num signed-num)
649 (:note "inline (signed-byte 64) arithmetic")
651 (:save-p :compute-only)
655 (if (typep y '(signed-byte 32))
657 (setf y-arg (register-inline-constant :qword y)))
658 (inst idiv eax y-arg)
665 (define-vop (fast-ash-c/fixnum=>fixnum)
668 (:args (number :scs (any-reg) :target result
669 :load-if (not (and (sc-is number any-reg control-stack)
670 (sc-is result any-reg control-stack)
671 (location= number result)))))
673 (:arg-types tagged-num (:constant integer))
674 (:results (result :scs (any-reg)
675 :load-if (not (and (sc-is number control-stack)
676 (sc-is result control-stack)
677 (location= number result)))))
678 (:result-types tagged-num)
681 (:variant-vars modularp)
683 (cond ((and (= amount 1) (not (location= number result)))
684 (inst lea result (make-ea :qword :base number :index number)))
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)
692 ;; this code is used both in ASH and ASH-MODFX, so
695 (inst shl result amount)
697 (inst sar result (- amount))
698 (inst and result (lognot fixnum-tag-mask)))))
699 ;; shifting left (zero fill)
702 (aver (not "Impossible: fixnum ASH should not be called with
703 constant shift greater than word length")))
704 (if (sc-is result any-reg)
706 (inst mov result 0)))
707 ;; shifting right (sign fill)
708 (t (inst sar result 63)
709 (inst and result (lognot fixnum-tag-mask))))))))
711 (define-vop (fast-ash-left/fixnum=>fixnum)
713 (:args (number :scs (any-reg) :target result
714 :load-if (not (and (sc-is number control-stack)
715 (sc-is result control-stack)
716 (location= number result))))
717 (amount :scs (unsigned-reg) :target ecx))
718 (:arg-types tagged-num positive-fixnum)
719 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
720 (:results (result :scs (any-reg) :from (:argument 0)
721 :load-if (not (and (sc-is number control-stack)
722 (sc-is result control-stack)
723 (location= number result)))))
724 (:result-types tagged-num)
730 ;; The result-type ensures us that this shift will not overflow.
731 (inst shl result :cl)))
733 (define-vop (fast-ash-c/signed=>signed)
736 (:args (number :scs (signed-reg) :target result
737 :load-if (not (and (sc-is number signed-stack)
738 (sc-is result signed-stack)
739 (location= number result)))))
741 (:arg-types signed-num (:constant integer))
742 (:results (result :scs (signed-reg)
743 :load-if (not (and (sc-is number signed-stack)
744 (sc-is result signed-stack)
745 (location= number result)))))
746 (:result-types signed-num)
749 (cond ((and (= amount 1) (not (location= number result)))
750 (inst lea result (make-ea :qword :base number :index number)))
751 ((and (= amount 2) (not (location= number result)))
752 (inst lea result (make-ea :qword :index number :scale 4)))
753 ((and (= amount 3) (not (location= number result)))
754 (inst lea result (make-ea :qword :index number :scale 8)))
757 (cond ((plusp amount) (inst shl result amount))
758 (t (inst sar result (min 63 (- amount)))))))))
760 (define-vop (fast-ash-c/unsigned=>unsigned)
763 (:args (number :scs (unsigned-reg) :target result
764 :load-if (not (and (sc-is number unsigned-stack)
765 (sc-is result unsigned-stack)
766 (location= number result)))))
768 (:arg-types unsigned-num (:constant integer))
769 (:results (result :scs (unsigned-reg)
770 :load-if (not (and (sc-is number unsigned-stack)
771 (sc-is result unsigned-stack)
772 (location= number result)))))
773 (:result-types unsigned-num)
776 (cond ((and (= amount 1) (not (location= number result)))
777 (inst lea result (make-ea :qword :base number :index number)))
778 ((and (= amount 2) (not (location= number result)))
779 (inst lea result (make-ea :qword :index number :scale 4)))
780 ((and (= amount 3) (not (location= number result)))
781 (inst lea result (make-ea :qword :index number :scale 8)))
784 (cond ((< -64 amount 64) ;; XXXX
785 ;; this code is used both in ASH and ASH-MOD32, so
788 (inst shl result amount)
789 (inst shr result (- amount))))
790 (t (if (sc-is result unsigned-reg)
792 (inst mov result 0))))))))
794 (define-vop (fast-ash-left/signed=>signed)
796 (:args (number :scs (signed-reg) :target result
797 :load-if (not (and (sc-is number signed-stack)
798 (sc-is result signed-stack)
799 (location= number result))))
800 (amount :scs (unsigned-reg) :target ecx))
801 (:arg-types signed-num positive-fixnum)
802 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
803 (:results (result :scs (signed-reg) :from (:argument 0)
804 :load-if (not (and (sc-is number signed-stack)
805 (sc-is result signed-stack)
806 (location= number result)))))
807 (:result-types signed-num)
813 (inst shl result :cl)))
815 (define-vop (fast-ash-left/unsigned=>unsigned)
817 (:args (number :scs (unsigned-reg) :target result
818 :load-if (not (and (sc-is number unsigned-stack)
819 (sc-is result unsigned-stack)
820 (location= number result))))
821 (amount :scs (unsigned-reg) :target ecx))
822 (:arg-types unsigned-num positive-fixnum)
823 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
824 (:results (result :scs (unsigned-reg) :from (:argument 0)
825 :load-if (not (and (sc-is number unsigned-stack)
826 (sc-is result unsigned-stack)
827 (location= number result)))))
828 (:result-types unsigned-num)
834 (inst shl result :cl)))
836 (define-vop (fast-ash/signed=>signed)
839 (:args (number :scs (signed-reg) :target result)
840 (amount :scs (signed-reg) :target ecx))
841 (:arg-types signed-num signed-num)
842 (:results (result :scs (signed-reg) :from (:argument 0)))
843 (:result-types signed-num)
844 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
850 (inst jmp :ns POSITIVE)
856 (inst sar result :cl)
860 ;; The result-type ensures us that this shift will not overflow.
861 (inst shl result :cl)
865 (define-vop (fast-ash/unsigned=>unsigned)
868 (:args (number :scs (unsigned-reg) :target result)
869 (amount :scs (signed-reg) :target ecx))
870 (:arg-types unsigned-num signed-num)
871 (:results (result :scs (unsigned-reg) :from (:argument 0)))
872 (:result-types unsigned-num)
873 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
879 (inst jmp :ns POSITIVE)
886 (inst shr result :cl)
890 ;; The result-type ensures us that this shift will not overflow.
891 (inst shl result :cl)
897 (defknown %lea (integer integer (member 1 2 4 8 16) (signed-byte 64))
899 (foldable flushable movable))
901 (defoptimizer (%lea derive-type) ((base index scale disp))
902 (when (and (constant-lvar-p scale)
903 (constant-lvar-p disp))
904 (let ((scale (lvar-value scale))
905 (disp (lvar-value disp))
906 (base-type (lvar-type base))
907 (index-type (lvar-type index)))
908 (when (and (numeric-type-p base-type)
909 (numeric-type-p index-type))
910 (let ((base-lo (numeric-type-low base-type))
911 (base-hi (numeric-type-high base-type))
912 (index-lo (numeric-type-low index-type))
913 (index-hi (numeric-type-high index-type)))
914 (make-numeric-type :class 'integer
916 :low (when (and base-lo index-lo)
917 (+ base-lo (* index-lo scale) disp))
918 :high (when (and base-hi index-hi)
919 (+ base-hi (* index-hi scale) disp))))))))
921 (defun %lea (base index scale disp)
922 (+ base (* index scale) disp))
926 (define-vop (%lea/unsigned=>unsigned)
929 (:args (base :scs (unsigned-reg))
930 (index :scs (unsigned-reg)))
932 (:arg-types unsigned-num unsigned-num
933 (:constant (member 1 2 4 8))
934 (:constant (signed-byte 64)))
935 (:results (r :scs (unsigned-reg)))
936 (:result-types unsigned-num)
938 (inst lea r (make-ea :qword :base base :index index
939 :scale scale :disp disp))))
941 (define-vop (%lea/signed=>signed)
944 (:args (base :scs (signed-reg))
945 (index :scs (signed-reg)))
947 (:arg-types signed-num signed-num
948 (:constant (member 1 2 4 8))
949 (:constant (signed-byte 64)))
950 (:results (r :scs (signed-reg)))
951 (:result-types signed-num)
953 (inst lea r (make-ea :qword :base base :index index
954 :scale scale :disp disp))))
956 (define-vop (%lea/fixnum=>fixnum)
959 (:args (base :scs (any-reg))
960 (index :scs (any-reg)))
962 (:arg-types tagged-num tagged-num
963 (:constant (member 1 2 4 8))
964 (:constant (signed-byte 64)))
965 (:results (r :scs (any-reg)))
966 (:result-types tagged-num)
968 (inst lea r (make-ea :qword :base base :index index
969 :scale scale :disp disp))))
971 ;;; FIXME: before making knowledge of this too public, it needs to be
972 ;;; fixed so that it's actually _faster_ than the non-CMOV version; at
973 ;;; least on my Celeron-XXX laptop, this version is marginally slower
974 ;;; than the above version with branches. -- CSR, 2003-09-04
975 (define-vop (fast-cmov-ash/unsigned=>unsigned)
978 (:args (number :scs (unsigned-reg) :target result)
979 (amount :scs (signed-reg) :target ecx))
980 (:arg-types unsigned-num signed-num)
981 (:results (result :scs (unsigned-reg) :from (:argument 0)))
982 (:result-types unsigned-num)
983 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
984 (:temporary (:sc any-reg :from (:eval 0) :to (:eval 1)) zero)
986 (:guard (member :cmov *backend-subfeatures*))
991 (inst jmp :ns POSITIVE)
994 (inst shr result :cl)
996 (inst cmov :nbe result zero)
1000 ;; The result-type ensures us that this shift will not overflow.
1001 (inst shl result :cl)
1005 (define-vop (signed-byte-64-len)
1006 (:translate integer-length)
1007 (:note "inline (signed-byte 64) integer-length")
1008 (:policy :fast-safe)
1009 (:args (arg :scs (signed-reg) :target res))
1010 (:arg-types signed-num)
1011 (:results (res :scs (unsigned-reg)))
1012 (:result-types unsigned-num)
1027 (define-vop (unsigned-byte-64-len)
1028 (:translate integer-length)
1029 (:note "inline (unsigned-byte 64) integer-length")
1030 (:policy :fast-safe)
1031 (:args (arg :scs (unsigned-reg)))
1032 (:arg-types unsigned-num)
1033 (:results (res :scs (unsigned-reg)))
1034 (:result-types unsigned-num)
1044 ;; INTEGER-LENGTH is implemented by using the BSR instruction, which
1045 ;; returns the position of the first 1-bit from the right. And that needs
1046 ;; to be incremented to get the width of the integer, and BSR doesn't
1047 ;; work on 0, so it needs a branch to handle 0.
1049 ;; But fixnums are tagged by being shifted left n-fixnum-tag-bits times,
1050 ;; untagging by shifting right n-fixnum-tag-bits-1 times (and if
1051 ;; n-fixnum-tag-bits = 1, no shifting is required), will make the
1052 ;; resulting integer one bit wider, making the increment unnecessary.
1053 ;; Then, to avoid calling BSR on 0, OR the result with 1. That sets the
1054 ;; first bit to 1, and if all other bits are 0, BSR will return 0,
1055 ;; which is the correct value for INTEGER-LENGTH.
1056 (define-vop (positive-fixnum-len)
1057 (:translate integer-length)
1058 (:note "inline positive fixnum integer-length")
1059 (:policy :fast-safe)
1060 (:args (arg :scs (any-reg)))
1061 (:arg-types positive-fixnum)
1062 (:results (res :scs (unsigned-reg)))
1063 (:result-types unsigned-num)
1066 (when (> n-fixnum-tag-bits 1)
1067 (inst shr res (1- n-fixnum-tag-bits)))
1069 (inst bsr res res)))
1071 (define-vop (fixnum-len)
1072 (:translate integer-length)
1073 (:note "inline fixnum integer-length")
1074 (:policy :fast-safe)
1075 (:args (arg :scs (any-reg) :target res))
1076 (:arg-types tagged-num)
1077 (:results (res :scs (unsigned-reg)))
1078 (:result-types unsigned-num)
1081 (when (> n-fixnum-tag-bits 1)
1082 (inst sar res (1- n-fixnum-tag-bits)))
1088 (inst bsr res res)))
1090 (define-vop (unsigned-byte-64-count)
1091 (:translate logcount)
1092 (:note "inline (unsigned-byte 64) logcount")
1093 (:policy :fast-safe)
1094 (:args (arg :scs (unsigned-reg) :target result))
1095 (:arg-types unsigned-num)
1096 (:results (result :scs (unsigned-reg)))
1097 (:result-types positive-fixnum)
1098 (:temporary (:sc unsigned-reg) temp)
1099 (:temporary (:sc unsigned-reg) mask)
1101 ;; See the comments below for how the algorithm works. The tricks
1102 ;; used can be found for example in AMD's software optimization
1103 ;; guide or at "http://www.hackersdelight.org/HDcode/pop.cc" in the
1104 ;; function "pop1", for 32-bit words. The extension to 64 bits is
1106 ;; Calculate 2-bit sums. Note that the value of a two-digit binary
1107 ;; number is the sum of the right digit and twice the left digit.
1108 ;; Thus we can calculate the sum of the two digits by shifting the
1109 ;; left digit to the right position and doing a two-bit subtraction.
1110 ;; This subtraction will never create a borrow and thus can be made
1111 ;; on all 32 2-digit numbers at once.
1115 (inst mov mask #x5555555555555555)
1116 (inst and result mask)
1117 (inst sub temp result)
1118 ;; Calculate 4-bit sums by straightforward shift, mask and add.
1119 ;; Note that we shift the source operand of the MOV and not its
1120 ;; destination so that the SHR and the MOV can execute in the same
1122 (inst mov result temp)
1124 (inst mov mask #x3333333333333333)
1125 (inst and result mask)
1126 (inst and temp mask)
1127 (inst add result temp)
1128 ;; Calculate 8-bit sums. Since each sum is at most 8, which fits
1129 ;; into 4 bits, we can apply the mask after the addition, saving one
1131 (inst mov temp result)
1133 (inst add result temp)
1134 (inst mov mask #x0f0f0f0f0f0f0f0f)
1135 (inst and result mask)
1136 ;; Add all 8 bytes at once by multiplying with #256r11111111.
1137 ;; We need to calculate only the lower 8 bytes of the product.
1138 ;; Of these the most significant byte contains the final result.
1139 ;; Note that there can be no overflow from one byte to the next
1140 ;; as the sum is at most 64 which needs only 7 bits.
1141 (inst mov mask #x0101010101010101)
1142 (inst imul result mask)
1143 (inst shr result 56)))
1145 ;;;; binary conditional VOPs
1147 (define-vop (fast-conditional)
1152 (:policy :fast-safe))
1154 ;;; constant variants are declared for 32 bits not 64 bits, because
1155 ;;; loading a 64 bit constant is silly
1157 (define-vop (fast-conditional/fixnum fast-conditional)
1158 (:args (x :scs (any-reg)
1159 :load-if (not (and (sc-is x control-stack)
1160 (sc-is y any-reg))))
1161 (y :scs (any-reg control-stack)))
1162 (:arg-types tagged-num tagged-num)
1163 (:note "inline fixnum comparison"))
1165 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
1166 (:args (x :scs (any-reg)
1167 :load-if (or (not (typep y 'short-tagged-num))
1168 (not (sc-is x any-reg control-stack)))))
1169 (:arg-types tagged-num (:constant fixnum))
1172 (define-vop (fast-conditional/signed fast-conditional)
1173 (:args (x :scs (signed-reg)
1174 :load-if (not (and (sc-is x signed-stack)
1175 (sc-is y signed-reg))))
1176 (y :scs (signed-reg signed-stack)))
1177 (:arg-types signed-num signed-num)
1178 (:note "inline (signed-byte 64) comparison"))
1180 (define-vop (fast-conditional-c/signed fast-conditional/signed)
1181 (:args (x :scs (signed-reg)
1182 :load-if (or (not (typep y '(signed-byte 32)))
1183 (not (sc-is x signed-reg signed-stack)))))
1184 (:arg-types signed-num (:constant (signed-byte 64)))
1187 (define-vop (fast-conditional/unsigned fast-conditional)
1188 (:args (x :scs (unsigned-reg)
1189 :load-if (not (and (sc-is x unsigned-stack)
1190 (sc-is y unsigned-reg))))
1191 (y :scs (unsigned-reg unsigned-stack)))
1192 (:arg-types unsigned-num unsigned-num)
1193 (:note "inline (unsigned-byte 64) comparison"))
1195 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
1196 (:args (x :scs (unsigned-reg)
1197 :load-if (or (not (typep y '(unsigned-byte 31)))
1198 (not (sc-is x unsigned-reg unsigned-stack)))))
1199 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
1202 ;; Stolen liberally from the x86 32-bit implementation.
1203 (macrolet ((define-logtest-vops ()
1205 ,@(loop for suffix in '(/fixnum -c/fixnum
1207 /unsigned -c/unsigned)
1208 for cost in '(4 3 6 5 6 5)
1210 `(define-vop (,(symbolicate "FAST-LOGTEST" suffix)
1211 ,(symbolicate "FAST-CONDITIONAL" suffix))
1212 (:translate logtest)
1215 (emit-optimized-test-inst x
1216 ,(if (eq suffix '-c/fixnum)
1217 ;; See whether (fixnumize y) fits in signed 32
1218 ;; to avoid chip's sign-extension of imm32 val.
1219 `(if (typep y 'short-tagged-num)
1221 (register-inline-constant :qword (fixnumize y)))
1222 `(cond ((typep y '(signed-byte 32)) ; same
1224 ((typep y '(or (unsigned-byte 64) (signed-byte 64)))
1225 (register-inline-constant :qword y))
1228 (define-logtest-vops))
1230 (defknown %logbitp (integer unsigned-byte) boolean
1231 (movable foldable flushable always-translatable))
1233 ;;; only for constant folding within the compiler
1234 (defun %logbitp (integer index)
1235 (logbitp index integer))
1237 ;;; too much work to do the non-constant case (maybe?)
1238 (define-vop (fast-logbitp-c/fixnum fast-conditional-c/fixnum)
1239 (:translate %logbitp)
1241 (:arg-types tagged-num (:constant (integer 0 #.(- 63 n-fixnum-tag-bits))))
1243 (inst bt x (+ y n-fixnum-tag-bits))))
1245 (define-vop (fast-logbitp/signed fast-conditional/signed)
1246 (:args (x :scs (signed-reg signed-stack))
1247 (y :scs (signed-reg)))
1248 (:translate %logbitp)
1253 (define-vop (fast-logbitp-c/signed fast-conditional-c/signed)
1254 (:translate %logbitp)
1256 (:arg-types signed-num (:constant (integer 0 63)))
1260 (define-vop (fast-logbitp/unsigned fast-conditional/unsigned)
1261 (:args (x :scs (unsigned-reg unsigned-stack))
1262 (y :scs (unsigned-reg)))
1263 (:translate %logbitp)
1268 (define-vop (fast-logbitp-c/unsigned fast-conditional-c/unsigned)
1269 (:translate %logbitp)
1271 (:arg-types unsigned-num (:constant (integer 0 63)))
1275 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
1278 (lambda (suffix cost signed)
1279 `(define-vop (;; FIXME: These could be done more
1280 ;; cleanly with SYMBOLICATE.
1281 ,(intern (format nil "~:@(FAST-IF-~A~A~)"
1284 (format nil "~:@(FAST-CONDITIONAL~A~)"
1287 (:conditional ,(if signed cond unsigned))
1292 `(if (typep y 'short-tagged-num)
1294 (register-inline-constant
1295 :qword (fixnumize y))))
1297 `(if (typep y '(signed-byte 32))
1299 (register-inline-constant
1302 `(if (typep y '(unsigned-byte 31))
1304 (register-inline-constant
1307 '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
1308 ; '(/fixnum /signed /unsigned)
1310 '(t t t t nil nil)))))
1312 (define-conditional-vop < :l :b :ge :ae)
1313 (define-conditional-vop > :g :a :le :be))
1315 (define-vop (fast-if-eql/signed fast-conditional/signed)
1320 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
1323 (cond ((and (sc-is x signed-reg) (zerop y))
1324 (inst test x x)) ; smaller instruction
1325 ((typep y '(signed-byte 32))
1328 (inst cmp x (register-inline-constant :qword y))))))
1330 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
1335 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
1338 (cond ((and (sc-is x unsigned-reg) (zerop y))
1339 (inst test x x)) ; smaller instruction
1340 ((typep y '(unsigned-byte 31))
1343 (inst cmp x (register-inline-constant :qword y))))))
1345 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
1348 ;;; These versions specify a fixnum restriction on their first arg. We have
1349 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
1350 ;;; the first arg and a higher cost. The reason for doing this is to prevent
1351 ;;; fixnum specific operations from being used on word integers, spuriously
1352 ;;; consing the argument.
1354 (define-vop (fast-eql/fixnum fast-conditional)
1355 (:args (x :scs (any-reg)
1356 :load-if (not (and (sc-is x control-stack)
1357 (sc-is y any-reg))))
1358 (y :scs (any-reg control-stack)))
1359 (:arg-types tagged-num tagged-num)
1360 (:note "inline fixnum comparison")
1365 (define-vop (generic-eql/fixnum fast-eql/fixnum)
1366 (:args (x :scs (any-reg descriptor-reg)
1367 :load-if (not (and (sc-is x control-stack)
1368 (sc-is y any-reg))))
1369 (y :scs (any-reg control-stack)))
1370 (:arg-types * tagged-num)
1373 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
1374 (:args (x :scs (any-reg)
1375 :load-if (or (not (typep y 'short-tagged-num))
1376 (not (sc-is x any-reg descriptor-reg control-stack)))))
1377 (:arg-types tagged-num (:constant fixnum))
1381 (cond ((and (sc-is x any-reg descriptor-reg) (zerop y))
1382 (inst test x x)) ; smaller instruction
1383 ((typep y 'short-tagged-num)
1384 (inst cmp x (fixnumize y)))
1386 (inst cmp x (register-inline-constant :qword (fixnumize y)))))))
1388 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
1389 (:args (x :scs (any-reg descriptor-reg)))
1390 (:arg-types * (:constant fixnum))
1393 ;;;; 32-bit logical operations
1395 ;;; Only the lower 6 bits of the shift amount are significant.
1396 (define-vop (shift-towards-someplace)
1397 (:policy :fast-safe)
1398 (:args (num :scs (unsigned-reg) :target r)
1399 (amount :scs (signed-reg) :target ecx))
1400 (:arg-types unsigned-num tagged-num)
1401 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
1402 (:results (r :scs (unsigned-reg) :from (:argument 0)))
1403 (:result-types unsigned-num))
1405 (define-vop (shift-towards-start shift-towards-someplace)
1406 (:translate shift-towards-start)
1407 (:note "SHIFT-TOWARDS-START")
1413 (define-vop (shift-towards-end shift-towards-someplace)
1414 (:translate shift-towards-end)
1415 (:note "SHIFT-TOWARDS-END")
1421 ;;;; Modular functions
1423 (defmacro define-mod-binop ((name prototype) function)
1424 `(define-vop (,name ,prototype)
1425 (:args (x :target r :scs (unsigned-reg signed-reg)
1426 :load-if (not (and (or (sc-is x unsigned-stack)
1427 (sc-is x signed-stack))
1428 (or (sc-is y unsigned-reg)
1429 (sc-is y signed-reg))
1430 (or (sc-is r unsigned-stack)
1431 (sc-is r signed-stack))
1433 (y :scs (unsigned-reg signed-reg unsigned-stack signed-stack)))
1434 (:arg-types untagged-num untagged-num)
1435 (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1436 :load-if (not (and (or (sc-is x unsigned-stack)
1437 (sc-is x signed-stack))
1438 (or (sc-is y unsigned-reg)
1439 (sc-is y unsigned-reg))
1440 (or (sc-is r unsigned-stack)
1441 (sc-is r unsigned-stack))
1443 (:result-types unsigned-num)
1444 (:translate ,function)))
1445 (defmacro define-mod-binop-c ((name prototype) function)
1446 `(define-vop (,name ,prototype)
1447 (:args (x :target r :scs (unsigned-reg signed-reg)
1448 :load-if (not (and (or (sc-is x unsigned-stack)
1449 (sc-is x signed-stack))
1450 (or (sc-is r unsigned-stack)
1451 (sc-is r signed-stack))
1453 (typep y '(signed-byte 32))))))
1455 (:arg-types untagged-num (:constant (or (unsigned-byte 64) (signed-byte 64))))
1456 (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1457 :load-if (not (and (or (sc-is x unsigned-stack)
1458 (sc-is x signed-stack))
1459 (or (sc-is r unsigned-stack)
1460 (sc-is r unsigned-stack))
1462 (:result-types unsigned-num)
1463 (:translate ,function)))
1465 (macrolet ((def (name -c-p)
1466 (let ((fun64 (intern (format nil "~S-MOD64" name)))
1467 (vopu (intern (format nil "FAST-~S/UNSIGNED=>UNSIGNED" name)))
1468 (vopcu (intern (format nil "FAST-~S-C/UNSIGNED=>UNSIGNED" name)))
1469 (vopf (intern (format nil "FAST-~S/FIXNUM=>FIXNUM" name)))
1470 (vopcf (intern (format nil "FAST-~S-C/FIXNUM=>FIXNUM" name)))
1471 (vop64u (intern (format nil "FAST-~S-MOD64/WORD=>UNSIGNED" name)))
1472 (vop64f (intern (format nil "FAST-~S-MOD64/FIXNUM=>FIXNUM" name)))
1473 (vop64cu (intern (format nil "FAST-~S-MOD64-C/WORD=>UNSIGNED" name)))
1474 (vop64cf (intern (format nil "FAST-~S-MOD64-C/FIXNUM=>FIXNUM" name)))
1475 (funfx (intern (format nil "~S-MODFX" name)))
1476 (vopfxf (intern (format nil "FAST-~S-MODFX/FIXNUM=>FIXNUM" name)))
1477 (vopfxcf (intern (format nil "FAST-~S-MODFX-C/FIXNUM=>FIXNUM" name))))
1479 (define-modular-fun ,fun64 (x y) ,name :untagged nil 64)
1480 (define-modular-fun ,funfx (x y) ,name :tagged t
1481 #.(- n-word-bits n-fixnum-tag-bits))
1482 (define-mod-binop (,vop64u ,vopu) ,fun64)
1483 (define-vop (,vop64f ,vopf) (:translate ,fun64))
1484 (define-vop (,vopfxf ,vopf) (:translate ,funfx))
1486 `((define-mod-binop-c (,vop64cu ,vopcu) ,fun64)
1487 (define-vop (,vopfxcf ,vopcf) (:translate ,funfx))))))))
1492 (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
1493 fast-ash-c/unsigned=>unsigned)
1494 (:translate ash-left-mod64))
1495 (define-vop (fast-ash-left-mod64/unsigned=>unsigned
1496 fast-ash-left/unsigned=>unsigned))
1497 (deftransform ash-left-mod64 ((integer count)
1498 ((unsigned-byte 64) (unsigned-byte 6)))
1499 (when (sb!c::constant-lvar-p count)
1500 (sb!c::give-up-ir1-transform))
1501 '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
1503 (define-vop (fast-ash-left-modfx-c/fixnum=>fixnum
1504 fast-ash-c/fixnum=>fixnum)
1506 (:translate ash-left-modfx))
1507 (define-vop (fast-ash-left-modfx/fixnum=>fixnum
1508 fast-ash-left/fixnum=>fixnum))
1509 (deftransform ash-left-modfx ((integer count)
1510 (fixnum (unsigned-byte 6)))
1511 (when (sb!c::constant-lvar-p count)
1512 (sb!c::give-up-ir1-transform))
1513 '(%primitive fast-ash-left-modfx/fixnum=>fixnum integer count))
1517 (defknown sb!vm::%lea-mod64 (integer integer (member 1 2 4 8) (signed-byte 64))
1519 (foldable flushable movable))
1520 (defknown sb!vm::%lea-modfx (integer integer (member 1 2 4 8) (signed-byte 64))
1522 (foldable flushable movable))
1524 (define-modular-fun-optimizer %lea ((base index scale disp) :untagged nil :width width)
1525 (when (and (<= width 64)
1526 (constant-lvar-p scale)
1527 (constant-lvar-p disp))
1528 (cut-to-width base :untagged width nil)
1529 (cut-to-width index :untagged width nil)
1530 'sb!vm::%lea-mod64))
1531 (define-modular-fun-optimizer %lea ((base index scale disp) :tagged t :width width)
1532 (when (and (<= width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
1533 (constant-lvar-p scale)
1534 (constant-lvar-p disp))
1535 (cut-to-width base :tagged width t)
1536 (cut-to-width index :tagged width t)
1537 'sb!vm::%lea-modfx))
1541 (defun sb!vm::%lea-mod64 (base index scale disp)
1542 (ldb (byte 64 0) (%lea base index scale disp)))
1543 (defun sb!vm::%lea-modfx (base index scale disp)
1544 (mask-signed-field (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)
1545 (%lea base index scale disp))))
1548 (defun sb!vm::%lea-mod64 (base index scale disp)
1549 (let ((base (logand base #xffffffffffffffff))
1550 (index (logand index #xffffffffffffffff)))
1551 ;; can't use modular version of %LEA, as we only have VOPs for
1552 ;; constant SCALE and DISP.
1553 (ldb (byte 64 0) (+ base (* index scale) disp))))
1554 (defun sb!vm::%lea-modfx (base index scale disp)
1555 (let* ((fixnum-width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
1556 (base (mask-signed-field fixnum-width base))
1557 (index (mask-signed-field fixnum-width index)))
1558 ;; can't use modular version of %LEA, as we only have VOPs for
1559 ;; constant SCALE and DISP.
1560 (mask-signed-field fixnum-width (+ base (* index scale) disp)))))
1562 (in-package "SB!VM")
1564 (define-vop (%lea-mod64/unsigned=>unsigned
1565 %lea/unsigned=>unsigned)
1566 (:translate %lea-mod64))
1567 (define-vop (%lea-modfx/fixnum=>fixnum
1568 %lea/fixnum=>fixnum)
1569 (:translate %lea-modfx))
1571 ;;; logical operations
1572 (define-modular-fun lognot-mod64 (x) lognot :untagged nil 64)
1573 (define-vop (lognot-mod64/unsigned=>unsigned)
1574 (:translate lognot-mod64)
1575 (:args (x :scs (unsigned-reg unsigned-stack) :target r
1576 :load-if (not (and (sc-is x unsigned-stack)
1577 (sc-is r unsigned-stack)
1579 (:arg-types unsigned-num)
1580 (:results (r :scs (unsigned-reg)
1581 :load-if (not (and (sc-is x unsigned-stack)
1582 (sc-is r unsigned-stack)
1584 (:result-types unsigned-num)
1585 (:policy :fast-safe)
1590 (define-source-transform logeqv (&rest args)
1591 (if (oddp (length args))
1593 `(lognot (logxor ,@args))))
1594 (define-source-transform logandc1 (x y)
1595 `(logand (lognot ,x) ,y))
1596 (define-source-transform logandc2 (x y)
1597 `(logand ,x (lognot ,y)))
1598 (define-source-transform logorc1 (x y)
1599 `(logior (lognot ,x) ,y))
1600 (define-source-transform logorc2 (x y)
1601 `(logior ,x (lognot ,y)))
1602 (define-source-transform lognor (x y)
1603 `(lognot (logior ,x ,y)))
1604 (define-source-transform lognand (x y)
1605 `(lognot (logand ,x ,y)))
1609 (define-vop (bignum-length get-header-data)
1610 (:translate sb!bignum:%bignum-length)
1611 (:policy :fast-safe))
1613 (define-vop (bignum-set-length set-header-data)
1614 (:translate sb!bignum:%bignum-set-length)
1615 (:policy :fast-safe))
1617 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
1618 (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
1619 (define-full-reffer+offset bignum--ref-with-offset * bignum-digits-offset
1620 other-pointer-lowtag (unsigned-reg) unsigned-num
1621 sb!bignum:%bignum-ref-with-offset)
1622 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
1623 (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
1625 (define-vop (digit-0-or-plus)
1626 (:translate sb!bignum:%digit-0-or-plusp)
1627 (:policy :fast-safe)
1628 (:args (digit :scs (unsigned-reg)))
1629 (:arg-types unsigned-num)
1632 (inst test digit digit)))
1635 ;;; For add and sub with carry the sc of carry argument is any-reg so
1636 ;;; that it may be passed as a fixnum or word and thus may be 0, 1, or
1637 ;;; 8. This is easy to deal with and may save a fixnum-word
1639 (define-vop (add-w/carry)
1640 (:translate sb!bignum:%add-with-carry)
1641 (:policy :fast-safe)
1642 (:args (a :scs (unsigned-reg) :target result)
1643 (b :scs (unsigned-reg unsigned-stack) :to :eval)
1644 (c :scs (any-reg) :target temp))
1645 (:arg-types unsigned-num unsigned-num positive-fixnum)
1646 (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
1647 (:results (result :scs (unsigned-reg) :from (:argument 0))
1648 (carry :scs (unsigned-reg)))
1649 (:result-types unsigned-num positive-fixnum)
1653 (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
1656 (inst adc carry carry)))
1658 ;;; Note: the borrow is 1 for no borrow and 0 for a borrow, the opposite
1659 ;;; of the x86-64 convention.
1660 (define-vop (sub-w/borrow)
1661 (:translate sb!bignum:%subtract-with-borrow)
1662 (:policy :fast-safe)
1663 (:args (a :scs (unsigned-reg) :to :eval :target result)
1664 (b :scs (unsigned-reg unsigned-stack) :to :result)
1665 (c :scs (any-reg control-stack)))
1666 (:arg-types unsigned-num unsigned-num positive-fixnum)
1667 (:results (result :scs (unsigned-reg) :from :eval)
1668 (borrow :scs (unsigned-reg)))
1669 (:result-types unsigned-num positive-fixnum)
1671 (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
1675 (inst sbb borrow 0)))
1678 (define-vop (bignum-mult-and-add-3-arg)
1679 (:translate sb!bignum:%multiply-and-add)
1680 (:policy :fast-safe)
1681 (:args (x :scs (unsigned-reg) :target eax)
1682 (y :scs (unsigned-reg unsigned-stack))
1683 (carry-in :scs (unsigned-reg unsigned-stack)))
1684 (:arg-types unsigned-num unsigned-num unsigned-num)
1685 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1686 :to (:result 1) :target lo) eax)
1687 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1688 :to (:result 0) :target hi) edx)
1689 (:results (hi :scs (unsigned-reg))
1690 (lo :scs (unsigned-reg)))
1691 (:result-types unsigned-num unsigned-num)
1695 (inst add eax carry-in)
1700 (define-vop (bignum-mult-and-add-4-arg)
1701 (:translate sb!bignum:%multiply-and-add)
1702 (:policy :fast-safe)
1703 (:args (x :scs (unsigned-reg) :target eax)
1704 (y :scs (unsigned-reg unsigned-stack))
1705 (prev :scs (unsigned-reg unsigned-stack))
1706 (carry-in :scs (unsigned-reg unsigned-stack)))
1707 (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1708 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1709 :to (:result 1) :target lo) eax)
1710 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1711 :to (:result 0) :target hi) edx)
1712 (:results (hi :scs (unsigned-reg))
1713 (lo :scs (unsigned-reg)))
1714 (:result-types unsigned-num unsigned-num)
1720 (inst add eax carry-in)
1726 (define-vop (bignum-mult)
1727 (:translate sb!bignum:%multiply)
1728 (:policy :fast-safe)
1729 (:args (x :scs (unsigned-reg) :target eax)
1730 (y :scs (unsigned-reg unsigned-stack)))
1731 (:arg-types unsigned-num unsigned-num)
1732 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1733 :to (:result 1) :target lo) eax)
1734 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1735 :to (:result 0) :target hi) edx)
1736 (:results (hi :scs (unsigned-reg))
1737 (lo :scs (unsigned-reg)))
1738 (:result-types unsigned-num unsigned-num)
1745 #!+multiply-high-vops
1747 (:translate sb!kernel:%multiply-high)
1748 (:policy :fast-safe)
1749 (:args (x :scs (unsigned-reg) :target eax)
1750 (y :scs (unsigned-reg unsigned-stack)))
1751 (:arg-types unsigned-num unsigned-num)
1752 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0))
1754 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1755 :to (:result 0) :target hi) edx)
1756 (:results (hi :scs (unsigned-reg)))
1757 (:result-types unsigned-num)
1763 #!+multiply-high-vops
1764 (define-vop (mulhi/fx)
1765 (:translate sb!kernel:%multiply-high)
1766 (:policy :fast-safe)
1767 (:args (x :scs (any-reg) :target eax)
1768 (y :scs (unsigned-reg unsigned-stack)))
1769 (:arg-types positive-fixnum unsigned-num)
1770 (:temporary (:sc any-reg :offset eax-offset :from (:argument 0)) eax)
1771 (:temporary (:sc any-reg :offset edx-offset :from (:argument 1)
1772 :to (:result 0) :target hi) edx)
1773 (:results (hi :scs (any-reg)))
1774 (:result-types positive-fixnum)
1779 (inst and hi (lognot fixnum-tag-mask))))
1781 (define-vop (bignum-lognot lognot-mod64/unsigned=>unsigned)
1782 (:translate sb!bignum:%lognot))
1784 (define-vop (fixnum-to-digit)
1785 (:translate sb!bignum:%fixnum-to-digit)
1786 (:policy :fast-safe)
1787 (:args (fixnum :scs (any-reg control-stack) :target digit))
1788 (:arg-types tagged-num)
1789 (:results (digit :scs (unsigned-reg)
1790 :load-if (not (and (sc-is fixnum control-stack)
1791 (sc-is digit unsigned-stack)
1792 (location= fixnum digit)))))
1793 (:result-types unsigned-num)
1796 (inst sar digit n-fixnum-tag-bits)))
1798 (define-vop (bignum-floor)
1799 (:translate sb!bignum:%bigfloor)
1800 (:policy :fast-safe)
1801 (:args (div-high :scs (unsigned-reg) :target edx)
1802 (div-low :scs (unsigned-reg) :target eax)
1803 (divisor :scs (unsigned-reg unsigned-stack)))
1804 (:arg-types unsigned-num unsigned-num unsigned-num)
1805 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
1806 :to (:result 0) :target quo) eax)
1807 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
1808 :to (:result 1) :target rem) edx)
1809 (:results (quo :scs (unsigned-reg))
1810 (rem :scs (unsigned-reg)))
1811 (:result-types unsigned-num unsigned-num)
1815 (inst div eax divisor)
1819 (define-vop (signify-digit)
1820 (:translate sb!bignum:%fixnum-digit-with-correct-sign)
1821 (:policy :fast-safe)
1822 (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
1823 (:arg-types unsigned-num)
1824 (:results (res :scs (any-reg signed-reg)
1825 :load-if (not (and (sc-is digit unsigned-stack)
1826 (sc-is res control-stack signed-stack)
1827 (location= digit res)))))
1828 (:result-types signed-num)
1831 (when (sc-is res any-reg control-stack)
1832 (inst shl res n-fixnum-tag-bits))))
1834 (define-vop (digit-ashr)
1835 (:translate sb!bignum:%ashr)
1836 (:policy :fast-safe)
1837 (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
1838 (count :scs (unsigned-reg) :target ecx))
1839 (:arg-types unsigned-num positive-fixnum)
1840 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
1841 (:results (result :scs (unsigned-reg) :from (:argument 0)
1842 :load-if (not (and (sc-is result unsigned-stack)
1843 (location= digit result)))))
1844 (:result-types unsigned-num)
1848 (inst sar result :cl)))
1850 (define-vop (digit-ashr/c)
1851 (:translate sb!bignum:%ashr)
1852 (:policy :fast-safe)
1853 (:args (digit :scs (unsigned-reg unsigned-stack) :target result))
1854 (:arg-types unsigned-num (:constant (integer 0 63)))
1856 (:results (result :scs (unsigned-reg) :from (:argument 0)
1857 :load-if (not (and (sc-is result unsigned-stack)
1858 (location= digit result)))))
1859 (:result-types unsigned-num)
1862 (inst sar result count)))
1864 (define-vop (digit-lshr digit-ashr)
1865 (:translate sb!bignum:%digit-logical-shift-right)
1869 (inst shr result :cl)))
1871 (define-vop (digit-ashl digit-ashr)
1872 (:translate sb!bignum:%ashl)
1876 (inst shl result :cl)))
1878 ;;;; static functions
1880 (define-static-fun two-arg-/ (x y) :translate /)
1882 (define-static-fun two-arg-gcd (x y) :translate gcd)
1883 (define-static-fun two-arg-lcm (x y) :translate lcm)
1885 (define-static-fun two-arg-and (x y) :translate logand)
1886 (define-static-fun two-arg-ior (x y) :translate logior)
1887 (define-static-fun two-arg-xor (x y) :translate logxor)
1892 (defun *-transformer (y)
1894 ((= y (ash 1 (integer-length y)))
1895 ;; there's a generic transform for y = 2^k
1896 (give-up-ir1-transform))
1897 ((member y '(3 5 9))
1898 ;; we can do these multiplications directly using LEA
1899 `(%lea x x ,(1- y) 0))
1901 ;; A normal 64-bit multiplication takes 4 cycles on Athlon 64/Opteron.
1902 ;; Optimizing multiplications (other than the above cases) to
1903 ;; shifts/adds/leas gives a maximum improvement of 1 cycle, but requires
1904 ;; quite a lot of hairy code.
1905 (give-up-ir1-transform))))
1907 (deftransform * ((x y)
1908 ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1910 "recode as leas, shifts and adds"
1911 (let ((y (lvar-value y)))
1913 (deftransform sb!vm::*-mod64
1914 ((x y) ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1916 "recode as leas, shifts and adds"
1917 (let ((y (lvar-value y)))
1920 (deftransform * ((x y)
1921 (fixnum (constant-arg (unsigned-byte 64)))
1923 "recode as leas, shifts and adds"
1924 (let ((y (lvar-value y)))
1926 (deftransform sb!vm::*-modfx
1927 ((x y) (fixnum (constant-arg (unsigned-byte 64)))
1929 "recode as leas, shifts and adds"
1930 (let ((y (lvar-value y)))