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)
1015 (if (sc-is res unsigned-reg)
1029 (define-vop (unsigned-byte-64-len)
1030 (:translate integer-length)
1031 (:note "inline (unsigned-byte 64) integer-length")
1032 (:policy :fast-safe)
1033 (:args (arg :scs (unsigned-reg)))
1034 (:arg-types unsigned-num)
1035 (:results (res :scs (unsigned-reg)))
1036 (:result-types unsigned-num)
1046 ;; INTEGER-LENGTH is implemented by using the BSR instruction, which
1047 ;; returns the position of the first 1-bit from the right. And that needs
1048 ;; to be incremented to get the width of the integer, and BSR doesn't
1049 ;; work on 0, so it needs a branch to handle 0.
1051 ;; But fixnums are tagged by being shifted left n-fixnum-tag-bits times,
1052 ;; untagging by shifting right n-fixnum-tag-bits-1 times (and if
1053 ;; n-fixnum-tag-bits = 1, no shifting is required), will make the
1054 ;; resulting integer one bit wider, making the increment unnecessary.
1055 ;; Then, to avoid calling BSR on 0, OR the result with 1. That sets the
1056 ;; first bit to 1, and if all other bits are 0, BSR will return 0,
1057 ;; which is the correct value for INTEGER-LENGTH.
1058 (define-vop (positive-fixnum-len)
1059 (:translate integer-length)
1060 (:note "inline positive fixnum integer-length")
1061 (:policy :fast-safe)
1062 (:args (arg :scs (any-reg)))
1063 (:arg-types positive-fixnum)
1064 (:results (res :scs (unsigned-reg)))
1065 (:result-types unsigned-num)
1068 (when (> n-fixnum-tag-bits 1)
1069 (inst shr res (1- n-fixnum-tag-bits)))
1071 (inst bsr res res)))
1073 (define-vop (fixnum-len)
1074 (:translate integer-length)
1075 (:note "inline fixnum integer-length")
1076 (:policy :fast-safe)
1077 (:args (arg :scs (any-reg) :target res))
1078 (:arg-types tagged-num)
1079 (:results (res :scs (unsigned-reg)))
1080 (:result-types unsigned-num)
1083 (when (> n-fixnum-tag-bits 1)
1084 (inst shr res (1- n-fixnum-tag-bits)))
1085 (if (sc-is res unsigned-reg)
1092 (inst bsr res res)))
1094 (define-vop (unsigned-byte-64-count)
1095 (:translate logcount)
1096 (:note "inline (unsigned-byte 64) logcount")
1097 (:policy :fast-safe)
1098 (:args (arg :scs (unsigned-reg) :target result))
1099 (:arg-types unsigned-num)
1100 (:results (result :scs (unsigned-reg)))
1101 (:result-types positive-fixnum)
1102 (:temporary (:sc unsigned-reg) temp)
1103 (:temporary (:sc unsigned-reg) mask)
1105 ;; See the comments below for how the algorithm works. The tricks
1106 ;; used can be found for example in AMD's software optimization
1107 ;; guide or at "http://www.hackersdelight.org/HDcode/pop.cc" in the
1108 ;; function "pop1", for 32-bit words. The extension to 64 bits is
1110 ;; Calculate 2-bit sums. Note that the value of a two-digit binary
1111 ;; number is the sum of the right digit and twice the left digit.
1112 ;; Thus we can calculate the sum of the two digits by shifting the
1113 ;; left digit to the right position and doing a two-bit subtraction.
1114 ;; This subtraction will never create a borrow and thus can be made
1115 ;; on all 32 2-digit numbers at once.
1119 (inst mov mask #x5555555555555555)
1120 (inst and result mask)
1121 (inst sub temp result)
1122 ;; Calculate 4-bit sums by straightforward shift, mask and add.
1123 ;; Note that we shift the source operand of the MOV and not its
1124 ;; destination so that the SHR and the MOV can execute in the same
1126 (inst mov result temp)
1128 (inst mov mask #x3333333333333333)
1129 (inst and result mask)
1130 (inst and temp mask)
1131 (inst add result temp)
1132 ;; Calculate 8-bit sums. Since each sum is at most 8, which fits
1133 ;; into 4 bits, we can apply the mask after the addition, saving one
1135 (inst mov temp result)
1137 (inst add result temp)
1138 (inst mov mask #x0f0f0f0f0f0f0f0f)
1139 (inst and result mask)
1140 ;; Add all 8 bytes at once by multiplying with #256r11111111.
1141 ;; We need to calculate only the lower 8 bytes of the product.
1142 ;; Of these the most significant byte contains the final result.
1143 ;; Note that there can be no overflow from one byte to the next
1144 ;; as the sum is at most 64 which needs only 7 bits.
1145 (inst mov mask #x0101010101010101)
1146 (inst imul result mask)
1147 (inst shr result 56)))
1149 ;;;; binary conditional VOPs
1151 (define-vop (fast-conditional)
1156 (:policy :fast-safe))
1158 ;;; constant variants are declared for 32 bits not 64 bits, because
1159 ;;; loading a 64 bit constant is silly
1161 (define-vop (fast-conditional/fixnum fast-conditional)
1162 (:args (x :scs (any-reg)
1163 :load-if (not (and (sc-is x control-stack)
1164 (sc-is y any-reg))))
1165 (y :scs (any-reg control-stack)))
1166 (:arg-types tagged-num tagged-num)
1167 (:note "inline fixnum comparison"))
1169 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
1170 (:args (x :scs (any-reg)
1171 :load-if (or (not (typep y 'short-tagged-num))
1172 (not (sc-is x any-reg control-stack)))))
1173 (:arg-types tagged-num (:constant fixnum))
1176 (define-vop (fast-conditional/signed fast-conditional)
1177 (:args (x :scs (signed-reg)
1178 :load-if (not (and (sc-is x signed-stack)
1179 (sc-is y signed-reg))))
1180 (y :scs (signed-reg signed-stack)))
1181 (:arg-types signed-num signed-num)
1182 (:note "inline (signed-byte 64) comparison"))
1184 (define-vop (fast-conditional-c/signed fast-conditional/signed)
1185 (:args (x :scs (signed-reg)
1186 :load-if (or (not (typep y '(signed-byte 32)))
1187 (not (sc-is x signed-reg signed-stack)))))
1188 (:arg-types signed-num (:constant (signed-byte 64)))
1191 (define-vop (fast-conditional/unsigned fast-conditional)
1192 (:args (x :scs (unsigned-reg)
1193 :load-if (not (and (sc-is x unsigned-stack)
1194 (sc-is y unsigned-reg))))
1195 (y :scs (unsigned-reg unsigned-stack)))
1196 (:arg-types unsigned-num unsigned-num)
1197 (:note "inline (unsigned-byte 64) comparison"))
1199 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
1200 (:args (x :scs (unsigned-reg)
1201 :load-if (or (not (typep y '(unsigned-byte 31)))
1202 (not (sc-is x unsigned-reg unsigned-stack)))))
1203 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
1206 ;; Stolen liberally from the x86 32-bit implementation.
1207 (macrolet ((define-logtest-vops ()
1209 ,@(loop for suffix in '(/fixnum -c/fixnum
1211 /unsigned -c/unsigned)
1212 for cost in '(4 3 6 5 6 5)
1214 `(define-vop (,(symbolicate "FAST-LOGTEST" suffix)
1215 ,(symbolicate "FAST-CONDITIONAL" suffix))
1216 (:translate logtest)
1219 (emit-optimized-test-inst x
1220 ,(if (eq suffix '-c/fixnum)
1221 ;; See whether (fixnumize y) fits in signed 32
1222 ;; to avoid chip's sign-extension of imm32 val.
1223 `(if (typep y 'short-tagged-num)
1225 (register-inline-constant :qword (fixnumize y)))
1226 `(cond ((typep y '(signed-byte 32)) ; same
1228 ((typep y '(or (unsigned-byte 64) (signed-byte 64)))
1229 (register-inline-constant :qword y))
1232 (define-logtest-vops))
1234 (defknown %logbitp (integer unsigned-byte) boolean
1235 (movable foldable flushable always-translatable))
1237 ;;; only for constant folding within the compiler
1238 (defun %logbitp (integer index)
1239 (logbitp index integer))
1241 ;;; too much work to do the non-constant case (maybe?)
1242 (define-vop (fast-logbitp-c/fixnum fast-conditional-c/fixnum)
1243 (:translate %logbitp)
1245 (:arg-types tagged-num (:constant (integer 0 #.(- 63 n-fixnum-tag-bits))))
1247 (inst bt x (+ y n-fixnum-tag-bits))))
1249 (define-vop (fast-logbitp/signed fast-conditional/signed)
1250 (:args (x :scs (signed-reg signed-stack))
1251 (y :scs (signed-reg)))
1252 (:translate %logbitp)
1257 (define-vop (fast-logbitp-c/signed fast-conditional-c/signed)
1258 (:translate %logbitp)
1260 (:arg-types signed-num (:constant (integer 0 63)))
1264 (define-vop (fast-logbitp/unsigned fast-conditional/unsigned)
1265 (:args (x :scs (unsigned-reg unsigned-stack))
1266 (y :scs (unsigned-reg)))
1267 (:translate %logbitp)
1272 (define-vop (fast-logbitp-c/unsigned fast-conditional-c/unsigned)
1273 (:translate %logbitp)
1275 (:arg-types unsigned-num (:constant (integer 0 63)))
1279 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
1282 (lambda (suffix cost signed)
1283 `(define-vop (;; FIXME: These could be done more
1284 ;; cleanly with SYMBOLICATE.
1285 ,(intern (format nil "~:@(FAST-IF-~A~A~)"
1288 (format nil "~:@(FAST-CONDITIONAL~A~)"
1291 (:conditional ,(if signed cond unsigned))
1296 `(if (typep y 'short-tagged-num)
1298 (register-inline-constant
1299 :qword (fixnumize y))))
1301 `(if (typep y '(signed-byte 32))
1303 (register-inline-constant
1306 `(if (typep y '(unsigned-byte 31))
1308 (register-inline-constant
1311 '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
1312 ; '(/fixnum /signed /unsigned)
1314 '(t t t t nil nil)))))
1316 (define-conditional-vop < :l :b :ge :ae)
1317 (define-conditional-vop > :g :a :le :be))
1319 (define-vop (fast-if-eql/signed fast-conditional/signed)
1324 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
1327 (cond ((and (sc-is x signed-reg) (zerop y))
1328 (inst test x x)) ; smaller instruction
1329 ((typep y '(signed-byte 32))
1332 (inst cmp x (register-inline-constant :qword y))))))
1334 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
1339 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
1342 (cond ((and (sc-is x unsigned-reg) (zerop y))
1343 (inst test x x)) ; smaller instruction
1344 ((typep y '(unsigned-byte 31))
1347 (inst cmp x (register-inline-constant :qword y))))))
1349 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
1352 ;;; These versions specify a fixnum restriction on their first arg. We have
1353 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
1354 ;;; the first arg and a higher cost. The reason for doing this is to prevent
1355 ;;; fixnum specific operations from being used on word integers, spuriously
1356 ;;; consing the argument.
1358 (define-vop (fast-eql/fixnum fast-conditional)
1359 (:args (x :scs (any-reg)
1360 :load-if (not (and (sc-is x control-stack)
1361 (sc-is y any-reg))))
1362 (y :scs (any-reg control-stack)))
1363 (:arg-types tagged-num tagged-num)
1364 (:note "inline fixnum comparison")
1369 (define-vop (generic-eql/fixnum fast-eql/fixnum)
1370 (:args (x :scs (any-reg descriptor-reg)
1371 :load-if (not (and (sc-is x control-stack)
1372 (sc-is y any-reg))))
1373 (y :scs (any-reg control-stack)))
1374 (:arg-types * tagged-num)
1377 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
1378 (:args (x :scs (any-reg)
1379 :load-if (or (not (typep y 'short-tagged-num))
1380 (not (sc-is x any-reg descriptor-reg control-stack)))))
1381 (:arg-types tagged-num (:constant fixnum))
1385 (cond ((and (sc-is x any-reg descriptor-reg) (zerop y))
1386 (inst test x x)) ; smaller instruction
1387 ((typep y 'short-tagged-num)
1388 (inst cmp x (fixnumize y)))
1390 (inst cmp x (register-inline-constant :qword (fixnumize y)))))))
1392 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
1393 (:args (x :scs (any-reg descriptor-reg)))
1394 (:arg-types * (:constant fixnum))
1397 ;;;; 32-bit logical operations
1399 ;;; Only the lower 6 bits of the shift amount are significant.
1400 (define-vop (shift-towards-someplace)
1401 (:policy :fast-safe)
1402 (:args (num :scs (unsigned-reg) :target r)
1403 (amount :scs (signed-reg) :target ecx))
1404 (:arg-types unsigned-num tagged-num)
1405 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
1406 (:results (r :scs (unsigned-reg) :from (:argument 0)))
1407 (:result-types unsigned-num))
1409 (define-vop (shift-towards-start shift-towards-someplace)
1410 (:translate shift-towards-start)
1411 (:note "SHIFT-TOWARDS-START")
1417 (define-vop (shift-towards-end shift-towards-someplace)
1418 (:translate shift-towards-end)
1419 (:note "SHIFT-TOWARDS-END")
1425 ;;;; Modular functions
1427 (defmacro define-mod-binop ((name prototype) function)
1428 `(define-vop (,name ,prototype)
1429 (:args (x :target r :scs (unsigned-reg signed-reg)
1430 :load-if (not (and (or (sc-is x unsigned-stack)
1431 (sc-is x signed-stack))
1432 (or (sc-is y unsigned-reg)
1433 (sc-is y signed-reg))
1434 (or (sc-is r unsigned-stack)
1435 (sc-is r signed-stack))
1437 (y :scs (unsigned-reg signed-reg unsigned-stack signed-stack)))
1438 (:arg-types untagged-num untagged-num)
1439 (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1440 :load-if (not (and (or (sc-is x unsigned-stack)
1441 (sc-is x signed-stack))
1442 (or (sc-is y unsigned-reg)
1443 (sc-is y unsigned-reg))
1444 (or (sc-is r unsigned-stack)
1445 (sc-is r unsigned-stack))
1447 (:result-types unsigned-num)
1448 (:translate ,function)))
1449 (defmacro define-mod-binop-c ((name prototype) function)
1450 `(define-vop (,name ,prototype)
1451 (:args (x :target r :scs (unsigned-reg signed-reg)
1452 :load-if (not (and (or (sc-is x unsigned-stack)
1453 (sc-is x signed-stack))
1454 (or (sc-is r unsigned-stack)
1455 (sc-is r signed-stack))
1457 (typep y '(signed-byte 32))))))
1459 (:arg-types untagged-num (:constant (or (unsigned-byte 64) (signed-byte 64))))
1460 (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1461 :load-if (not (and (or (sc-is x unsigned-stack)
1462 (sc-is x signed-stack))
1463 (or (sc-is r unsigned-stack)
1464 (sc-is r unsigned-stack))
1466 (:result-types unsigned-num)
1467 (:translate ,function)))
1469 (macrolet ((def (name -c-p)
1470 (let ((fun64 (intern (format nil "~S-MOD64" name)))
1471 (vopu (intern (format nil "FAST-~S/UNSIGNED=>UNSIGNED" name)))
1472 (vopcu (intern (format nil "FAST-~S-C/UNSIGNED=>UNSIGNED" name)))
1473 (vopf (intern (format nil "FAST-~S/FIXNUM=>FIXNUM" name)))
1474 (vopcf (intern (format nil "FAST-~S-C/FIXNUM=>FIXNUM" name)))
1475 (vop64u (intern (format nil "FAST-~S-MOD64/WORD=>UNSIGNED" name)))
1476 (vop64f (intern (format nil "FAST-~S-MOD64/FIXNUM=>FIXNUM" name)))
1477 (vop64cu (intern (format nil "FAST-~S-MOD64-C/WORD=>UNSIGNED" name)))
1478 (vop64cf (intern (format nil "FAST-~S-MOD64-C/FIXNUM=>FIXNUM" name)))
1479 (funfx (intern (format nil "~S-MODFX" name)))
1480 (vopfxf (intern (format nil "FAST-~S-MODFX/FIXNUM=>FIXNUM" name)))
1481 (vopfxcf (intern (format nil "FAST-~S-MODFX-C/FIXNUM=>FIXNUM" name))))
1483 (define-modular-fun ,fun64 (x y) ,name :untagged nil 64)
1484 (define-modular-fun ,funfx (x y) ,name :tagged t
1485 #.(- n-word-bits n-fixnum-tag-bits))
1486 (define-mod-binop (,vop64u ,vopu) ,fun64)
1487 (define-vop (,vop64f ,vopf) (:translate ,fun64))
1488 (define-vop (,vopfxf ,vopf) (:translate ,funfx))
1490 `((define-mod-binop-c (,vop64cu ,vopcu) ,fun64)
1491 (define-vop (,vopfxcf ,vopcf) (:translate ,funfx))))))))
1496 (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
1497 fast-ash-c/unsigned=>unsigned)
1498 (:translate ash-left-mod64))
1499 (define-vop (fast-ash-left-mod64/unsigned=>unsigned
1500 fast-ash-left/unsigned=>unsigned))
1501 (deftransform ash-left-mod64 ((integer count)
1502 ((unsigned-byte 64) (unsigned-byte 6)))
1503 (when (sb!c::constant-lvar-p count)
1504 (sb!c::give-up-ir1-transform))
1505 '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
1507 (define-vop (fast-ash-left-modfx-c/fixnum=>fixnum
1508 fast-ash-c/fixnum=>fixnum)
1510 (:translate ash-left-modfx))
1511 (define-vop (fast-ash-left-modfx/fixnum=>fixnum
1512 fast-ash-left/fixnum=>fixnum))
1513 (deftransform ash-left-modfx ((integer count)
1514 (fixnum (unsigned-byte 6)))
1515 (when (sb!c::constant-lvar-p count)
1516 (sb!c::give-up-ir1-transform))
1517 '(%primitive fast-ash-left-modfx/fixnum=>fixnum integer count))
1521 (defknown sb!vm::%lea-mod64 (integer integer (member 1 2 4 8) (signed-byte 64))
1523 (foldable flushable movable))
1524 (defknown sb!vm::%lea-modfx (integer integer (member 1 2 4 8) (signed-byte 64))
1526 (foldable flushable movable))
1528 (define-modular-fun-optimizer %lea ((base index scale disp) :untagged nil :width width)
1529 (when (and (<= width 64)
1530 (constant-lvar-p scale)
1531 (constant-lvar-p disp))
1532 (cut-to-width base :untagged width nil)
1533 (cut-to-width index :untagged width nil)
1534 'sb!vm::%lea-mod64))
1535 (define-modular-fun-optimizer %lea ((base index scale disp) :tagged t :width width)
1536 (when (and (<= width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
1537 (constant-lvar-p scale)
1538 (constant-lvar-p disp))
1539 (cut-to-width base :tagged width t)
1540 (cut-to-width index :tagged width t)
1541 'sb!vm::%lea-modfx))
1545 (defun sb!vm::%lea-mod64 (base index scale disp)
1546 (ldb (byte 64 0) (%lea base index scale disp)))
1547 (defun sb!vm::%lea-modfx (base index scale disp)
1548 (mask-signed-field (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)
1549 (%lea base index scale disp))))
1552 (defun sb!vm::%lea-mod64 (base index scale disp)
1553 (let ((base (logand base #xffffffffffffffff))
1554 (index (logand index #xffffffffffffffff)))
1555 ;; can't use modular version of %LEA, as we only have VOPs for
1556 ;; constant SCALE and DISP.
1557 (ldb (byte 64 0) (+ base (* index scale) disp))))
1558 (defun sb!vm::%lea-modfx (base index scale disp)
1559 (let* ((fixnum-width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
1560 (base (mask-signed-field fixnum-width base))
1561 (index (mask-signed-field fixnum-width index)))
1562 ;; can't use modular version of %LEA, as we only have VOPs for
1563 ;; constant SCALE and DISP.
1564 (mask-signed-field fixnum-width (+ base (* index scale) disp)))))
1566 (in-package "SB!VM")
1568 (define-vop (%lea-mod64/unsigned=>unsigned
1569 %lea/unsigned=>unsigned)
1570 (:translate %lea-mod64))
1571 (define-vop (%lea-modfx/fixnum=>fixnum
1572 %lea/fixnum=>fixnum)
1573 (:translate %lea-modfx))
1575 ;;; logical operations
1576 (define-modular-fun lognot-mod64 (x) lognot :untagged nil 64)
1577 (define-vop (lognot-mod64/unsigned=>unsigned)
1578 (:translate lognot-mod64)
1579 (:args (x :scs (unsigned-reg unsigned-stack) :target r
1580 :load-if (not (and (sc-is x unsigned-stack)
1581 (sc-is r unsigned-stack)
1583 (:arg-types unsigned-num)
1584 (:results (r :scs (unsigned-reg)
1585 :load-if (not (and (sc-is x unsigned-stack)
1586 (sc-is r unsigned-stack)
1588 (:result-types unsigned-num)
1589 (:policy :fast-safe)
1594 (define-source-transform logeqv (&rest args)
1595 (if (oddp (length args))
1597 `(lognot (logxor ,@args))))
1598 (define-source-transform logandc1 (x y)
1599 `(logand (lognot ,x) ,y))
1600 (define-source-transform logandc2 (x y)
1601 `(logand ,x (lognot ,y)))
1602 (define-source-transform logorc1 (x y)
1603 `(logior (lognot ,x) ,y))
1604 (define-source-transform logorc2 (x y)
1605 `(logior ,x (lognot ,y)))
1606 (define-source-transform lognor (x y)
1607 `(lognot (logior ,x ,y)))
1608 (define-source-transform lognand (x y)
1609 `(lognot (logand ,x ,y)))
1613 (define-vop (bignum-length get-header-data)
1614 (:translate sb!bignum:%bignum-length)
1615 (:policy :fast-safe))
1617 (define-vop (bignum-set-length set-header-data)
1618 (:translate sb!bignum:%bignum-set-length)
1619 (:policy :fast-safe))
1621 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
1622 (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
1623 (define-full-reffer+offset bignum--ref-with-offset * bignum-digits-offset
1624 other-pointer-lowtag (unsigned-reg) unsigned-num
1625 sb!bignum:%bignum-ref-with-offset)
1626 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
1627 (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
1629 (define-vop (digit-0-or-plus)
1630 (:translate sb!bignum:%digit-0-or-plusp)
1631 (:policy :fast-safe)
1632 (:args (digit :scs (unsigned-reg)))
1633 (:arg-types unsigned-num)
1636 (inst test digit digit)))
1639 ;;; For add and sub with carry the sc of carry argument is any-reg so
1640 ;;; that it may be passed as a fixnum or word and thus may be 0, 1, or
1641 ;;; 8. This is easy to deal with and may save a fixnum-word
1643 (define-vop (add-w/carry)
1644 (:translate sb!bignum:%add-with-carry)
1645 (:policy :fast-safe)
1646 (:args (a :scs (unsigned-reg) :target result)
1647 (b :scs (unsigned-reg unsigned-stack) :to :eval)
1648 (c :scs (any-reg) :target temp))
1649 (:arg-types unsigned-num unsigned-num positive-fixnum)
1650 (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
1651 (:results (result :scs (unsigned-reg) :from (:argument 0))
1652 (carry :scs (unsigned-reg)))
1653 (:result-types unsigned-num positive-fixnum)
1657 (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
1660 (inst adc carry carry)))
1662 ;;; Note: the borrow is 1 for no borrow and 0 for a borrow, the opposite
1663 ;;; of the x86-64 convention.
1664 (define-vop (sub-w/borrow)
1665 (:translate sb!bignum:%subtract-with-borrow)
1666 (:policy :fast-safe)
1667 (:args (a :scs (unsigned-reg) :to :eval :target result)
1668 (b :scs (unsigned-reg unsigned-stack) :to :result)
1669 (c :scs (any-reg control-stack)))
1670 (:arg-types unsigned-num unsigned-num positive-fixnum)
1671 (:results (result :scs (unsigned-reg) :from :eval)
1672 (borrow :scs (unsigned-reg)))
1673 (:result-types unsigned-num positive-fixnum)
1675 (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
1679 (inst sbb borrow 0)))
1682 (define-vop (bignum-mult-and-add-3-arg)
1683 (:translate sb!bignum:%multiply-and-add)
1684 (:policy :fast-safe)
1685 (:args (x :scs (unsigned-reg) :target eax)
1686 (y :scs (unsigned-reg unsigned-stack))
1687 (carry-in :scs (unsigned-reg unsigned-stack)))
1688 (:arg-types unsigned-num unsigned-num unsigned-num)
1689 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1690 :to (:result 1) :target lo) eax)
1691 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1692 :to (:result 0) :target hi) edx)
1693 (:results (hi :scs (unsigned-reg))
1694 (lo :scs (unsigned-reg)))
1695 (:result-types unsigned-num unsigned-num)
1699 (inst add eax carry-in)
1704 (define-vop (bignum-mult-and-add-4-arg)
1705 (:translate sb!bignum:%multiply-and-add)
1706 (:policy :fast-safe)
1707 (:args (x :scs (unsigned-reg) :target eax)
1708 (y :scs (unsigned-reg unsigned-stack))
1709 (prev :scs (unsigned-reg unsigned-stack))
1710 (carry-in :scs (unsigned-reg unsigned-stack)))
1711 (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1712 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1713 :to (:result 1) :target lo) eax)
1714 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1715 :to (:result 0) :target hi) edx)
1716 (:results (hi :scs (unsigned-reg))
1717 (lo :scs (unsigned-reg)))
1718 (:result-types unsigned-num unsigned-num)
1724 (inst add eax carry-in)
1730 (define-vop (bignum-mult)
1731 (:translate sb!bignum:%multiply)
1732 (:policy :fast-safe)
1733 (:args (x :scs (unsigned-reg) :target eax)
1734 (y :scs (unsigned-reg unsigned-stack)))
1735 (:arg-types unsigned-num unsigned-num)
1736 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1737 :to (:result 1) :target lo) eax)
1738 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1739 :to (:result 0) :target hi) edx)
1740 (:results (hi :scs (unsigned-reg))
1741 (lo :scs (unsigned-reg)))
1742 (:result-types unsigned-num unsigned-num)
1749 #!+multiply-high-vops
1751 (:translate sb!kernel:%multiply-high)
1752 (:policy :fast-safe)
1753 (:args (x :scs (unsigned-reg) :target eax)
1754 (y :scs (unsigned-reg unsigned-stack)))
1755 (:arg-types unsigned-num unsigned-num)
1756 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0))
1758 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1759 :to (:result 0) :target hi) edx)
1760 (:results (hi :scs (unsigned-reg)))
1761 (:result-types unsigned-num)
1767 #!+multiply-high-vops
1768 (define-vop (mulhi/fx)
1769 (:translate sb!kernel:%multiply-high)
1770 (:policy :fast-safe)
1771 (:args (x :scs (any-reg) :target eax)
1772 (y :scs (unsigned-reg unsigned-stack)))
1773 (:arg-types positive-fixnum unsigned-num)
1774 (:temporary (:sc any-reg :offset eax-offset :from (:argument 0)) eax)
1775 (:temporary (:sc any-reg :offset edx-offset :from (:argument 1)
1776 :to (:result 0) :target hi) edx)
1777 (:results (hi :scs (any-reg)))
1778 (:result-types positive-fixnum)
1783 (inst and hi (lognot fixnum-tag-mask))))
1785 (define-vop (bignum-lognot lognot-mod64/unsigned=>unsigned)
1786 (:translate sb!bignum:%lognot))
1788 (define-vop (fixnum-to-digit)
1789 (:translate sb!bignum:%fixnum-to-digit)
1790 (:policy :fast-safe)
1791 (:args (fixnum :scs (any-reg control-stack) :target digit))
1792 (:arg-types tagged-num)
1793 (:results (digit :scs (unsigned-reg)
1794 :load-if (not (and (sc-is fixnum control-stack)
1795 (sc-is digit unsigned-stack)
1796 (location= fixnum digit)))))
1797 (:result-types unsigned-num)
1800 (inst sar digit n-fixnum-tag-bits)))
1802 (define-vop (bignum-floor)
1803 (:translate sb!bignum:%bigfloor)
1804 (:policy :fast-safe)
1805 (:args (div-high :scs (unsigned-reg) :target edx)
1806 (div-low :scs (unsigned-reg) :target eax)
1807 (divisor :scs (unsigned-reg unsigned-stack)))
1808 (:arg-types unsigned-num unsigned-num unsigned-num)
1809 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
1810 :to (:result 0) :target quo) eax)
1811 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
1812 :to (:result 1) :target rem) edx)
1813 (:results (quo :scs (unsigned-reg))
1814 (rem :scs (unsigned-reg)))
1815 (:result-types unsigned-num unsigned-num)
1819 (inst div eax divisor)
1823 (define-vop (signify-digit)
1824 (:translate sb!bignum:%fixnum-digit-with-correct-sign)
1825 (:policy :fast-safe)
1826 (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
1827 (:arg-types unsigned-num)
1828 (:results (res :scs (any-reg signed-reg)
1829 :load-if (not (and (sc-is digit unsigned-stack)
1830 (sc-is res control-stack signed-stack)
1831 (location= digit res)))))
1832 (:result-types signed-num)
1835 (when (sc-is res any-reg control-stack)
1836 (inst shl res n-fixnum-tag-bits))))
1838 (define-vop (digit-ashr)
1839 (:translate sb!bignum:%ashr)
1840 (:policy :fast-safe)
1841 (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
1842 (count :scs (unsigned-reg) :target ecx))
1843 (:arg-types unsigned-num positive-fixnum)
1844 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
1845 (:results (result :scs (unsigned-reg) :from (:argument 0)
1846 :load-if (not (and (sc-is result unsigned-stack)
1847 (location= digit result)))))
1848 (:result-types unsigned-num)
1852 (inst sar result :cl)))
1854 (define-vop (digit-ashr/c)
1855 (:translate sb!bignum:%ashr)
1856 (:policy :fast-safe)
1857 (:args (digit :scs (unsigned-reg unsigned-stack) :target result))
1858 (:arg-types unsigned-num (:constant (integer 0 63)))
1860 (:results (result :scs (unsigned-reg) :from (:argument 0)
1861 :load-if (not (and (sc-is result unsigned-stack)
1862 (location= digit result)))))
1863 (:result-types unsigned-num)
1866 (inst sar result count)))
1868 (define-vop (digit-lshr digit-ashr)
1869 (:translate sb!bignum:%digit-logical-shift-right)
1873 (inst shr result :cl)))
1875 (define-vop (digit-ashl digit-ashr)
1876 (:translate sb!bignum:%ashl)
1880 (inst shl result :cl)))
1882 ;;;; static functions
1884 (define-static-fun two-arg-/ (x y) :translate /)
1886 (define-static-fun two-arg-gcd (x y) :translate gcd)
1887 (define-static-fun two-arg-lcm (x y) :translate lcm)
1889 (define-static-fun two-arg-and (x y) :translate logand)
1890 (define-static-fun two-arg-ior (x y) :translate logior)
1891 (define-static-fun two-arg-xor (x y) :translate logxor)
1896 (defun *-transformer (y)
1898 ((= y (ash 1 (integer-length y)))
1899 ;; there's a generic transform for y = 2^k
1900 (give-up-ir1-transform))
1901 ((member y '(3 5 9))
1902 ;; we can do these multiplications directly using LEA
1903 `(%lea x x ,(1- y) 0))
1905 ;; A normal 64-bit multiplication takes 4 cycles on Athlon 64/Opteron.
1906 ;; Optimizing multiplications (other than the above cases) to
1907 ;; shifts/adds/leas gives a maximum improvement of 1 cycle, but requires
1908 ;; quite a lot of hairy code.
1909 (give-up-ir1-transform))))
1911 (deftransform * ((x y)
1912 ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1914 "recode as leas, shifts and adds"
1915 (let ((y (lvar-value y)))
1917 (deftransform sb!vm::*-mod64
1918 ((x y) ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1920 "recode as leas, shifts and adds"
1921 (let ((y (lvar-value y)))
1924 (deftransform * ((x y)
1925 (fixnum (constant-arg (unsigned-byte 64)))
1927 "recode as leas, shifts and adds"
1928 (let ((y (lvar-value y)))
1930 (deftransform sb!vm::*-modfx
1931 ((x y) (fixnum (constant-arg (unsigned-byte 64)))
1933 "recode as leas, shifts and adds"
1934 (let ((y (lvar-value y)))