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.
16 (define-vop (fast-safe-arith-op)
21 (define-vop (fixnum-unop fast-safe-arith-op)
22 (:args (x :scs (any-reg) :target res))
23 (:results (res :scs (any-reg)))
24 (:note "inline fixnum arithmetic")
25 (:arg-types tagged-num)
26 (:result-types tagged-num))
28 (define-vop (signed-unop fast-safe-arith-op)
29 (:args (x :scs (signed-reg) :target res))
30 (:results (res :scs (signed-reg)))
31 (:note "inline (signed-byte 64) arithmetic")
32 (:arg-types signed-num)
33 (:result-types signed-num))
35 (define-vop (fast-negate/fixnum fixnum-unop)
41 (define-vop (fast-negate/signed signed-unop)
47 (define-vop (fast-lognot/fixnum fixnum-unop)
51 (inst xor res (fixnumize -1))))
53 (define-vop (fast-lognot/signed signed-unop)
59 ;;;; binary fixnum operations
61 ;;; Assume that any constant operand is the second arg...
63 (define-vop (fast-fixnum-binop fast-safe-arith-op)
64 (:args (x :target r :scs (any-reg)
65 :load-if (not (and (sc-is x control-stack)
67 (sc-is r control-stack)
69 (y :scs (any-reg control-stack)))
70 (:arg-types tagged-num tagged-num)
71 (:results (r :scs (any-reg) :from (:argument 0)
72 :load-if (not (and (sc-is x control-stack)
74 (sc-is r control-stack)
76 (:result-types tagged-num)
77 (:note "inline fixnum arithmetic"))
79 (define-vop (fast-unsigned-binop fast-safe-arith-op)
80 (:args (x :target r :scs (unsigned-reg)
81 :load-if (not (and (sc-is x unsigned-stack)
82 (sc-is y unsigned-reg)
83 (sc-is r unsigned-stack)
85 (y :scs (unsigned-reg unsigned-stack)))
86 (:arg-types unsigned-num unsigned-num)
87 (:results (r :scs (unsigned-reg) :from (:argument 0)
88 :load-if (not (and (sc-is x unsigned-stack)
89 (sc-is y unsigned-reg)
90 (sc-is r unsigned-stack)
92 (:result-types unsigned-num)
93 (:note "inline (unsigned-byte 64) arithmetic"))
95 (define-vop (fast-signed-binop fast-safe-arith-op)
96 (:args (x :target r :scs (signed-reg)
97 :load-if (not (and (sc-is x signed-stack)
99 (sc-is r signed-stack)
101 (y :scs (signed-reg signed-stack)))
102 (:arg-types signed-num signed-num)
103 (:results (r :scs (signed-reg) :from (:argument 0)
104 :load-if (not (and (sc-is x signed-stack)
106 (sc-is r signed-stack)
108 (:result-types signed-num)
109 (:note "inline (signed-byte 64) arithmetic"))
111 (define-vop (fast-fixnum-binop-c fast-safe-arith-op)
112 (:args (x :target r :scs (any-reg)
113 :load-if (or (not (typep y '(signed-byte 29)))
114 (not (sc-is x any-reg control-stack)))))
116 (:arg-types tagged-num (:constant fixnum))
117 (:results (r :scs (any-reg)
118 :load-if (or (not (location= x r))
119 (not (typep y '(signed-byte 29))))))
120 (:result-types tagged-num)
121 (:note "inline fixnum arithmetic"))
123 (define-vop (fast-unsigned-binop-c fast-safe-arith-op)
124 (:args (x :target r :scs (unsigned-reg)
125 :load-if (or (not (typep y '(unsigned-byte 31)))
126 (not (sc-is x unsigned-reg unsigned-stack)))))
128 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
129 (:results (r :scs (unsigned-reg)
130 :load-if (or (not (location= x r))
131 (not (typep y '(unsigned-byte 31))))))
132 (:result-types unsigned-num)
133 (:note "inline (unsigned-byte 64) arithmetic"))
135 (define-vop (fast-signed-binop-c fast-safe-arith-op)
136 (:args (x :target r :scs (signed-reg)
137 :load-if (or (not (typep y '(signed-byte 32)))
138 (not (sc-is x signed-reg signed-stack)))))
140 (:arg-types signed-num (:constant (signed-byte 64)))
141 (:results (r :scs (signed-reg)
142 :load-if (or (not (location= x r))
143 (not (typep y '(signed-byte 32))))))
144 (:result-types signed-num)
145 (:note "inline (signed-byte 64) arithmetic"))
147 (macrolet ((define-binop (translate untagged-penalty op)
149 (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
151 (:translate ,translate)
155 (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
157 (:translate ,translate)
160 (inst ,op r (if (typep y '(signed-byte 29))
162 (register-inline-constant :qword (fixnumize y))))))
163 (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
165 (:translate ,translate)
166 (:generator ,(1+ untagged-penalty)
169 (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
171 (:translate ,translate)
172 (:generator ,untagged-penalty
174 (inst ,op r (if (typep y '(signed-byte 32))
176 (register-inline-constant :qword y)))))
177 (define-vop (,(symbolicate "FAST-"
179 "/UNSIGNED=>UNSIGNED")
181 (:translate ,translate)
182 (:generator ,(1+ untagged-penalty)
185 (define-vop (,(symbolicate 'fast-
187 '-c/unsigned=>unsigned)
188 fast-unsigned-binop-c)
189 (:translate ,translate)
190 (:generator ,untagged-penalty
192 (inst ,op r (if (typep y '(unsigned-byte 31))
194 (register-inline-constant :qword y))))))))
196 ;;(define-binop + 4 add)
197 (define-binop - 4 sub)
198 (define-binop logand 2 and)
199 (define-binop logior 2 or)
200 (define-binop logxor 2 xor))
202 ;;; Special handling of add on the x86; can use lea to avoid a
203 ;;; register load, otherwise it uses add.
204 (define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op)
206 (:args (x :scs (any-reg) :target r
207 :load-if (not (and (sc-is x control-stack)
209 (sc-is r control-stack)
211 (y :scs (any-reg control-stack)))
212 (:arg-types tagged-num tagged-num)
213 (:results (r :scs (any-reg) :from (:argument 0)
214 :load-if (not (and (sc-is x control-stack)
216 (sc-is r control-stack)
218 (:result-types tagged-num)
219 (:note "inline fixnum arithmetic")
221 (cond ((and (sc-is x any-reg) (sc-is y any-reg) (sc-is r any-reg)
222 (not (location= x r)))
223 (inst lea r (make-ea :qword :base x :index y :scale 1)))
228 (define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op)
230 (:args (x :target r :scs (any-reg)
231 :load-if (or (not (typep y '(signed-byte 29)))
232 (not (sc-is x any-reg control-stack)))))
234 (:arg-types tagged-num (:constant fixnum))
235 (:results (r :scs (any-reg)
236 :load-if (or (not (location= x r))
237 (not (typep y '(signed-byte 29))))))
238 (:result-types tagged-num)
239 (:note "inline fixnum arithmetic")
241 (cond ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r))
242 (typep y '(signed-byte 29)))
243 (inst lea r (make-ea :qword :base x :disp (fixnumize y))))
244 ((typep y '(signed-byte 29))
246 (inst add r (fixnumize y)))
249 (inst add r (register-inline-constant :qword (fixnumize y)))))))
251 (define-vop (fast-+/signed=>signed fast-safe-arith-op)
253 (:args (x :scs (signed-reg) :target r
254 :load-if (not (and (sc-is x signed-stack)
256 (sc-is r signed-stack)
258 (y :scs (signed-reg signed-stack)))
259 (:arg-types signed-num signed-num)
260 (:results (r :scs (signed-reg) :from (:argument 0)
261 :load-if (not (and (sc-is x signed-stack)
264 (:result-types signed-num)
265 (:note "inline (signed-byte 64) arithmetic")
267 (cond ((and (sc-is x signed-reg) (sc-is y signed-reg) (sc-is r signed-reg)
268 (not (location= x r)))
269 (inst lea r (make-ea :qword :base x :index y :scale 1)))
275 ;;;; Special logand cases: (logand signed unsigned) => unsigned
277 (define-vop (fast-logand/signed-unsigned=>unsigned
278 fast-logand/unsigned=>unsigned)
279 (:args (x :target r :scs (signed-reg)
280 :load-if (not (and (sc-is x signed-stack)
281 (sc-is y unsigned-reg)
282 (sc-is r unsigned-stack)
284 (y :scs (unsigned-reg unsigned-stack)))
285 (:arg-types signed-num unsigned-num))
287 (define-vop (fast-logand-c/signed-unsigned=>unsigned
288 fast-logand-c/unsigned=>unsigned)
289 (:args (x :target r :scs (signed-reg)
290 :load-if (or (not (typep y '(unsigned-byte 31)))
291 (not (sc-is r signed-reg signed-stack)))))
292 (:arg-types signed-num (:constant (unsigned-byte 64))))
294 (define-vop (fast-logand/unsigned-signed=>unsigned
295 fast-logand/unsigned=>unsigned)
296 (:args (x :target r :scs (unsigned-reg)
297 :load-if (not (and (sc-is x unsigned-stack)
299 (sc-is r unsigned-stack)
301 (y :scs (signed-reg signed-stack)))
302 (:arg-types unsigned-num signed-num))
305 (define-vop (fast-+-c/signed=>signed fast-safe-arith-op)
307 (:args (x :target r :scs (signed-reg)
308 :load-if (or (not (typep y '(signed-byte 32)))
309 (not (sc-is r signed-reg signed-stack)))))
311 (:arg-types signed-num (:constant (signed-byte 64)))
312 (:results (r :scs (signed-reg)
313 :load-if (or (not (location= x r))
314 (not (typep y '(signed-byte 32))))))
315 (:result-types signed-num)
316 (:note "inline (signed-byte 64) arithmetic")
318 (cond ((and (sc-is x signed-reg) (sc-is r signed-reg)
319 (not (location= x r))
320 (typep y '(signed-byte 32)))
321 (inst lea r (make-ea :qword :base x :disp y)))
326 ((typep y '(signed-byte 32))
329 (inst add r (register-inline-constant :qword y))))))))
331 (define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op)
333 (:args (x :scs (unsigned-reg) :target r
334 :load-if (not (and (sc-is x unsigned-stack)
335 (sc-is y unsigned-reg)
336 (sc-is r unsigned-stack)
338 (y :scs (unsigned-reg unsigned-stack)))
339 (:arg-types unsigned-num unsigned-num)
340 (:results (r :scs (unsigned-reg) :from (:argument 0)
341 :load-if (not (and (sc-is x unsigned-stack)
342 (sc-is y unsigned-reg)
343 (sc-is r unsigned-stack)
345 (:result-types unsigned-num)
346 (:note "inline (unsigned-byte 64) arithmetic")
348 (cond ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg)
349 (sc-is r unsigned-reg) (not (location= x r)))
350 (inst lea r (make-ea :qword :base x :index y :scale 1)))
355 (define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op)
357 (:args (x :target r :scs (unsigned-reg)
358 :load-if (or (not (typep y '(unsigned-byte 31)))
359 (not (sc-is x unsigned-reg unsigned-stack)))))
361 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
362 (:results (r :scs (unsigned-reg)
363 :load-if (or (not (location= x r))
364 (not (typep y '(unsigned-byte 31))))))
365 (:result-types unsigned-num)
366 (:note "inline (unsigned-byte 64) arithmetic")
368 (cond ((and (sc-is x unsigned-reg) (sc-is r unsigned-reg)
369 (not (location= x r))
370 (typep y '(unsigned-byte 31)))
371 (inst lea r (make-ea :qword :base x :disp y)))
376 ((typep y '(unsigned-byte 31))
379 (inst add r (register-inline-constant :qword y))))))))
381 ;;;; multiplication and division
383 (define-vop (fast-*/fixnum=>fixnum fast-safe-arith-op)
385 ;; We need different loading characteristics.
386 (:args (x :scs (any-reg) :target r)
387 (y :scs (any-reg control-stack)))
388 (:arg-types tagged-num tagged-num)
389 (:results (r :scs (any-reg) :from (:argument 0)))
390 (:result-types tagged-num)
391 (:note "inline fixnum arithmetic")
394 (inst sar r n-fixnum-tag-bits)
397 (define-vop (fast-*-c/fixnum=>fixnum fast-safe-arith-op)
399 ;; We need different loading characteristics.
400 (:args (x :scs (any-reg)
401 :load-if (or (not (typep y '(signed-byte 32)))
402 (not (sc-is x any-reg control-stack)))))
404 (:arg-types tagged-num (:constant fixnum))
405 (:results (r :scs (any-reg)))
406 (:result-types tagged-num)
407 (:note "inline fixnum arithmetic")
409 (cond ((typep y '(signed-byte 32))
413 (inst imul r (register-inline-constant :qword y))))))
415 (define-vop (fast-*/signed=>signed fast-safe-arith-op)
417 ;; We need different loading characteristics.
418 (:args (x :scs (signed-reg) :target r)
419 (y :scs (signed-reg signed-stack)))
420 (:arg-types signed-num signed-num)
421 (:results (r :scs (signed-reg) :from (:argument 0)))
422 (:result-types signed-num)
423 (:note "inline (signed-byte 64) arithmetic")
428 (define-vop (fast-*-c/signed=>signed fast-safe-arith-op)
430 ;; We need different loading characteristics.
431 (:args (x :scs (signed-reg)
432 :load-if (or (not (typep y '(signed-byte 32)))
433 (not (sc-is x signed-reg signed-stack)))))
435 (:arg-types signed-num (:constant (signed-byte 64)))
436 (:results (r :scs (signed-reg)))
437 (:result-types signed-num)
438 (:note "inline (signed-byte 64) arithmetic")
440 (cond ((typep y '(signed-byte 32))
444 (inst imul r (register-inline-constant :qword y))))))
446 (define-vop (fast-*/unsigned=>unsigned fast-safe-arith-op)
448 (:args (x :scs (unsigned-reg) :target eax)
449 (y :scs (unsigned-reg unsigned-stack)))
450 (:arg-types unsigned-num unsigned-num)
451 (:temporary (:sc unsigned-reg :offset eax-offset :target r
452 :from (:argument 0) :to :result) eax)
453 (:temporary (:sc unsigned-reg :offset edx-offset
454 :from :eval :to :result) edx)
456 (:results (r :scs (unsigned-reg)))
457 (:result-types unsigned-num)
458 (:note "inline (unsigned-byte 64) arithmetic")
460 (:save-p :compute-only)
466 (define-vop (fast-*-c/unsigned=>unsigned fast-safe-arith-op)
468 (:args (x :scs (unsigned-reg) :target eax))
470 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
471 (:temporary (:sc unsigned-reg :offset eax-offset :target r
472 :from (:argument 0) :to :result) eax)
473 (:temporary (:sc unsigned-reg :offset edx-offset
474 :from :eval :to :result) edx)
476 (:results (r :scs (unsigned-reg)))
477 (:result-types unsigned-num)
478 (:note "inline (unsigned-byte 64) arithmetic")
480 (:save-p :compute-only)
483 (inst mul eax (register-inline-constant :qword y))
487 (define-vop (fast-truncate/fixnum=>fixnum fast-safe-arith-op)
488 (:translate truncate)
489 (:args (x :scs (any-reg) :target eax)
490 (y :scs (any-reg control-stack)))
491 (:arg-types tagged-num tagged-num)
492 (:temporary (:sc signed-reg :offset eax-offset :target quo
493 :from (:argument 0) :to (:result 0)) eax)
494 (:temporary (:sc unsigned-reg :offset edx-offset :target rem
495 :from (:argument 0) :to (:result 1)) edx)
496 (:results (quo :scs (any-reg))
497 (rem :scs (any-reg)))
498 (:result-types tagged-num tagged-num)
499 (:note "inline fixnum arithmetic")
501 (:save-p :compute-only)
503 (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
504 (if (sc-is y any-reg)
505 (inst test y y) ; smaller instruction
511 (if (location= quo eax)
512 (inst shl eax n-fixnum-tag-bits)
513 (inst lea quo (make-ea :qword :index eax
514 :scale (ash 1 n-fixnum-tag-bits))))
517 (define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
518 (:translate truncate)
519 (:args (x :scs (any-reg) :target eax))
521 (:arg-types tagged-num (:constant fixnum))
522 (:temporary (:sc signed-reg :offset eax-offset :target quo
523 :from :argument :to (:result 0)) eax)
524 (:temporary (:sc any-reg :offset edx-offset :target rem
525 :from :eval :to (:result 1)) edx)
526 (:temporary (:sc any-reg :from :eval :to :result) y-arg)
527 (:results (quo :scs (any-reg))
528 (rem :scs (any-reg)))
529 (:result-types tagged-num tagged-num)
530 (:note "inline fixnum arithmetic")
532 (:save-p :compute-only)
536 (if (typep y '(signed-byte 29))
537 (inst mov y-arg (fixnumize y))
538 (setf y-arg (register-inline-constant :qword (fixnumize y))))
539 (inst idiv eax y-arg)
540 (if (location= quo eax)
541 (inst shl eax n-fixnum-tag-bits)
542 (inst lea quo (make-ea :qword :index eax
543 :scale (ash 1 n-fixnum-tag-bits))))
546 (define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
547 (:translate truncate)
548 (:args (x :scs (unsigned-reg) :target eax)
549 (y :scs (unsigned-reg signed-stack)))
550 (:arg-types unsigned-num unsigned-num)
551 (:temporary (:sc unsigned-reg :offset eax-offset :target quo
552 :from (:argument 0) :to (:result 0)) eax)
553 (:temporary (:sc unsigned-reg :offset edx-offset :target rem
554 :from (:argument 0) :to (:result 1)) edx)
555 (:results (quo :scs (unsigned-reg))
556 (rem :scs (unsigned-reg)))
557 (:result-types unsigned-num unsigned-num)
558 (:note "inline (unsigned-byte 64) arithmetic")
560 (:save-p :compute-only)
562 (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
563 (if (sc-is y unsigned-reg)
564 (inst test y y) ; smaller instruction
573 (define-vop (fast-truncate-c/unsigned=>unsigned fast-safe-arith-op)
574 (:translate truncate)
575 (:args (x :scs (unsigned-reg) :target eax))
577 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
578 (:temporary (:sc unsigned-reg :offset eax-offset :target quo
579 :from :argument :to (:result 0)) eax)
580 (:temporary (:sc unsigned-reg :offset edx-offset :target rem
581 :from :eval :to (:result 1)) edx)
582 (:temporary (:sc unsigned-reg :from :eval :to :result) y-arg)
583 (:results (quo :scs (unsigned-reg))
584 (rem :scs (unsigned-reg)))
585 (:result-types unsigned-num unsigned-num)
586 (:note "inline (unsigned-byte 64) arithmetic")
588 (:save-p :compute-only)
592 (if (typep y '(unsigned-byte 31))
594 (setf y-arg (register-inline-constant :qword y)))
599 (define-vop (fast-truncate/signed=>signed fast-safe-arith-op)
600 (:translate truncate)
601 (:args (x :scs (signed-reg) :target eax)
602 (y :scs (signed-reg signed-stack)))
603 (:arg-types signed-num signed-num)
604 (:temporary (:sc signed-reg :offset eax-offset :target quo
605 :from (:argument 0) :to (:result 0)) eax)
606 (:temporary (:sc signed-reg :offset edx-offset :target rem
607 :from (:argument 0) :to (:result 1)) edx)
608 (:results (quo :scs (signed-reg))
609 (rem :scs (signed-reg)))
610 (:result-types signed-num signed-num)
611 (:note "inline (signed-byte 64) arithmetic")
613 (:save-p :compute-only)
615 (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
616 (if (sc-is y signed-reg)
617 (inst test y y) ; smaller instruction
626 (define-vop (fast-truncate-c/signed=>signed fast-safe-arith-op)
627 (:translate truncate)
628 (:args (x :scs (signed-reg) :target eax))
630 (:arg-types signed-num (:constant (signed-byte 64)))
631 (:temporary (:sc signed-reg :offset eax-offset :target quo
632 :from :argument :to (:result 0)) eax)
633 (:temporary (:sc signed-reg :offset edx-offset :target rem
634 :from :eval :to (:result 1)) edx)
635 (:temporary (:sc signed-reg :from :eval :to :result) y-arg)
636 (:results (quo :scs (signed-reg))
637 (rem :scs (signed-reg)))
638 (:result-types signed-num signed-num)
639 (:note "inline (signed-byte 64) arithmetic")
641 (:save-p :compute-only)
645 (if (typep y '(signed-byte 32))
647 (setf y-arg (register-inline-constant :qword y)))
648 (inst idiv eax y-arg)
655 (define-vop (fast-ash-c/fixnum=>fixnum)
658 (:args (number :scs (any-reg) :target result
659 :load-if (not (and (sc-is number any-reg control-stack)
660 (sc-is result any-reg control-stack)
661 (location= number result)))))
663 (:arg-types tagged-num (:constant integer))
664 (:results (result :scs (any-reg)
665 :load-if (not (and (sc-is number control-stack)
666 (sc-is result control-stack)
667 (location= number result)))))
668 (:result-types tagged-num)
671 (:variant-vars modularp)
673 (cond ((and (= amount 1) (not (location= number result)))
674 (inst lea result (make-ea :qword :base number :index number)))
675 ((and (= amount 2) (not (location= number result)))
676 (inst lea result (make-ea :qword :index number :scale 4)))
677 ((and (= amount 3) (not (location= number result)))
678 (inst lea result (make-ea :qword :index number :scale 8)))
681 (cond ((< -64 amount 64)
682 ;; this code is used both in ASH and ASH-MODFX, so
685 (inst shl result amount)
687 (inst sar result (- amount))
688 (inst and result (lognot fixnum-tag-mask)))))
689 ;; shifting left (zero fill)
692 (aver (not "Impossible: fixnum ASH should not be called with
693 constant shift greater than word length")))
694 (if (sc-is result any-reg)
696 (inst mov result 0)))
697 ;; shifting right (sign fill)
698 (t (inst sar result 63)
699 (inst and result (lognot fixnum-tag-mask))))))))
701 (define-vop (fast-ash-left/fixnum=>fixnum)
703 (:args (number :scs (any-reg) :target result
704 :load-if (not (and (sc-is number control-stack)
705 (sc-is result control-stack)
706 (location= number result))))
707 (amount :scs (unsigned-reg) :target ecx))
708 (:arg-types tagged-num positive-fixnum)
709 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
710 (:results (result :scs (any-reg) :from (:argument 0)
711 :load-if (not (and (sc-is number control-stack)
712 (sc-is result control-stack)
713 (location= number result)))))
714 (:result-types tagged-num)
720 ;; The result-type ensures us that this shift will not overflow.
721 (inst shl result :cl)))
723 (define-vop (fast-ash-c/signed=>signed)
726 (:args (number :scs (signed-reg) :target result
727 :load-if (not (and (sc-is number signed-stack)
728 (sc-is result signed-stack)
729 (location= number result)))))
731 (:arg-types signed-num (:constant integer))
732 (:results (result :scs (signed-reg)
733 :load-if (not (and (sc-is number signed-stack)
734 (sc-is result signed-stack)
735 (location= number result)))))
736 (:result-types signed-num)
739 (cond ((and (= amount 1) (not (location= number result)))
740 (inst lea result (make-ea :qword :base number :index number)))
741 ((and (= amount 2) (not (location= number result)))
742 (inst lea result (make-ea :qword :index number :scale 4)))
743 ((and (= amount 3) (not (location= number result)))
744 (inst lea result (make-ea :qword :index number :scale 8)))
747 (cond ((plusp amount) (inst shl result amount))
748 (t (inst sar result (min 63 (- amount)))))))))
750 (define-vop (fast-ash-c/unsigned=>unsigned)
753 (:args (number :scs (unsigned-reg) :target result
754 :load-if (not (and (sc-is number unsigned-stack)
755 (sc-is result unsigned-stack)
756 (location= number result)))))
758 (:arg-types unsigned-num (:constant integer))
759 (:results (result :scs (unsigned-reg)
760 :load-if (not (and (sc-is number unsigned-stack)
761 (sc-is result unsigned-stack)
762 (location= number result)))))
763 (:result-types unsigned-num)
766 (cond ((and (= amount 1) (not (location= number result)))
767 (inst lea result (make-ea :qword :base number :index number)))
768 ((and (= amount 2) (not (location= number result)))
769 (inst lea result (make-ea :qword :index number :scale 4)))
770 ((and (= amount 3) (not (location= number result)))
771 (inst lea result (make-ea :qword :index number :scale 8)))
774 (cond ((< -64 amount 64) ;; XXXX
775 ;; this code is used both in ASH and ASH-MOD32, so
778 (inst shl result amount)
779 (inst shr result (- amount))))
780 (t (if (sc-is result unsigned-reg)
782 (inst mov result 0))))))))
784 (define-vop (fast-ash-left/signed=>signed)
786 (:args (number :scs (signed-reg) :target result
787 :load-if (not (and (sc-is number signed-stack)
788 (sc-is result signed-stack)
789 (location= number result))))
790 (amount :scs (unsigned-reg) :target ecx))
791 (:arg-types signed-num positive-fixnum)
792 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
793 (:results (result :scs (signed-reg) :from (:argument 0)
794 :load-if (not (and (sc-is number signed-stack)
795 (sc-is result signed-stack)
796 (location= number result)))))
797 (:result-types signed-num)
803 (inst shl result :cl)))
805 (define-vop (fast-ash-left/unsigned=>unsigned)
807 (:args (number :scs (unsigned-reg) :target result
808 :load-if (not (and (sc-is number unsigned-stack)
809 (sc-is result unsigned-stack)
810 (location= number result))))
811 (amount :scs (unsigned-reg) :target ecx))
812 (:arg-types unsigned-num positive-fixnum)
813 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
814 (:results (result :scs (unsigned-reg) :from (:argument 0)
815 :load-if (not (and (sc-is number unsigned-stack)
816 (sc-is result unsigned-stack)
817 (location= number result)))))
818 (:result-types unsigned-num)
824 (inst shl result :cl)))
826 (define-vop (fast-ash/signed=>signed)
829 (:args (number :scs (signed-reg) :target result)
830 (amount :scs (signed-reg) :target ecx))
831 (:arg-types signed-num signed-num)
832 (:results (result :scs (signed-reg) :from (:argument 0)))
833 (:result-types signed-num)
834 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
840 (inst jmp :ns POSITIVE)
846 (inst sar result :cl)
850 ;; The result-type ensures us that this shift will not overflow.
851 (inst shl result :cl)
855 (define-vop (fast-ash/unsigned=>unsigned)
858 (:args (number :scs (unsigned-reg) :target result)
859 (amount :scs (signed-reg) :target ecx))
860 (:arg-types unsigned-num signed-num)
861 (:results (result :scs (unsigned-reg) :from (:argument 0)))
862 (:result-types unsigned-num)
863 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
869 (inst jmp :ns POSITIVE)
876 (inst shr result :cl)
880 ;; The result-type ensures us that this shift will not overflow.
881 (inst shl result :cl)
887 (defknown %lea (integer integer (member 1 2 4 8 16) (signed-byte 64))
889 (foldable flushable movable))
891 (defoptimizer (%lea derive-type) ((base index scale disp))
892 (when (and (constant-lvar-p scale)
893 (constant-lvar-p disp))
894 (let ((scale (lvar-value scale))
895 (disp (lvar-value disp))
896 (base-type (lvar-type base))
897 (index-type (lvar-type index)))
898 (when (and (numeric-type-p base-type)
899 (numeric-type-p index-type))
900 (let ((base-lo (numeric-type-low base-type))
901 (base-hi (numeric-type-high base-type))
902 (index-lo (numeric-type-low index-type))
903 (index-hi (numeric-type-high index-type)))
904 (make-numeric-type :class 'integer
906 :low (when (and base-lo index-lo)
907 (+ base-lo (* index-lo scale) disp))
908 :high (when (and base-hi index-hi)
909 (+ base-hi (* index-hi scale) disp))))))))
911 (defun %lea (base index scale disp)
912 (+ base (* index scale) disp))
916 (define-vop (%lea/unsigned=>unsigned)
919 (:args (base :scs (unsigned-reg))
920 (index :scs (unsigned-reg)))
922 (:arg-types unsigned-num unsigned-num
923 (:constant (member 1 2 4 8))
924 (:constant (signed-byte 64)))
925 (:results (r :scs (unsigned-reg)))
926 (:result-types unsigned-num)
928 (inst lea r (make-ea :qword :base base :index index
929 :scale scale :disp disp))))
931 (define-vop (%lea/signed=>signed)
934 (:args (base :scs (signed-reg))
935 (index :scs (signed-reg)))
937 (:arg-types signed-num signed-num
938 (:constant (member 1 2 4 8))
939 (:constant (signed-byte 64)))
940 (:results (r :scs (signed-reg)))
941 (:result-types signed-num)
943 (inst lea r (make-ea :qword :base base :index index
944 :scale scale :disp disp))))
946 (define-vop (%lea/fixnum=>fixnum)
949 (:args (base :scs (any-reg))
950 (index :scs (any-reg)))
952 (:arg-types tagged-num tagged-num
953 (:constant (member 1 2 4 8))
954 (:constant (signed-byte 64)))
955 (:results (r :scs (any-reg)))
956 (:result-types tagged-num)
958 (inst lea r (make-ea :qword :base base :index index
959 :scale scale :disp disp))))
961 ;;; FIXME: before making knowledge of this too public, it needs to be
962 ;;; fixed so that it's actually _faster_ than the non-CMOV version; at
963 ;;; least on my Celeron-XXX laptop, this version is marginally slower
964 ;;; than the above version with branches. -- CSR, 2003-09-04
965 (define-vop (fast-cmov-ash/unsigned=>unsigned)
968 (:args (number :scs (unsigned-reg) :target result)
969 (amount :scs (signed-reg) :target ecx))
970 (:arg-types unsigned-num signed-num)
971 (:results (result :scs (unsigned-reg) :from (:argument 0)))
972 (:result-types unsigned-num)
973 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
974 (:temporary (:sc any-reg :from (:eval 0) :to (:eval 1)) zero)
976 (:guard (member :cmov *backend-subfeatures*))
981 (inst jmp :ns POSITIVE)
984 (inst shr result :cl)
986 (inst cmov :nbe result zero)
990 ;; The result-type ensures us that this shift will not overflow.
991 (inst shl result :cl)
995 (define-vop (signed-byte-64-len)
996 (:translate integer-length)
997 (:note "inline (signed-byte 64) integer-length")
999 (:args (arg :scs (signed-reg) :target res))
1000 (:arg-types signed-num)
1001 (:results (res :scs (unsigned-reg)))
1002 (:result-types unsigned-num)
1005 (if (sc-is res unsigned-reg)
1019 (define-vop (unsigned-byte-64-len)
1020 (:translate integer-length)
1021 (:note "inline (unsigned-byte 64) integer-length")
1022 (:policy :fast-safe)
1023 (:args (arg :scs (unsigned-reg)))
1024 (:arg-types unsigned-num)
1025 (:results (res :scs (unsigned-reg)))
1026 (:result-types unsigned-num)
1036 (define-vop (unsigned-byte-64-count)
1037 (:translate logcount)
1038 (:note "inline (unsigned-byte 64) logcount")
1039 (:policy :fast-safe)
1040 (:args (arg :scs (unsigned-reg) :target result))
1041 (:arg-types unsigned-num)
1042 (:results (result :scs (unsigned-reg)))
1043 (:result-types positive-fixnum)
1044 (:temporary (:sc unsigned-reg) temp)
1045 (:temporary (:sc unsigned-reg) mask)
1047 ;; See the comments below for how the algorithm works. The tricks
1048 ;; used can be found for example in AMD's software optimization
1049 ;; guide or at "http://www.hackersdelight.org/HDcode/pop.cc" in the
1050 ;; function "pop1", for 32-bit words. The extension to 64 bits is
1052 ;; Calculate 2-bit sums. Note that the value of a two-digit binary
1053 ;; number is the sum of the right digit and twice the left digit.
1054 ;; Thus we can calculate the sum of the two digits by shifting the
1055 ;; left digit to the right position and doing a two-bit subtraction.
1056 ;; This subtraction will never create a borrow and thus can be made
1057 ;; on all 32 2-digit numbers at once.
1061 (inst mov mask #x5555555555555555)
1062 (inst and result mask)
1063 (inst sub temp result)
1064 ;; Calculate 4-bit sums by straightforward shift, mask and add.
1065 ;; Note that we shift the source operand of the MOV and not its
1066 ;; destination so that the SHR and the MOV can execute in the same
1068 (inst mov result temp)
1070 (inst mov mask #x3333333333333333)
1071 (inst and result mask)
1072 (inst and temp mask)
1073 (inst add result temp)
1074 ;; Calculate 8-bit sums. Since each sum is at most 8, which fits
1075 ;; into 4 bits, we can apply the mask after the addition, saving one
1077 (inst mov temp result)
1079 (inst add result temp)
1080 (inst mov mask #x0f0f0f0f0f0f0f0f)
1081 (inst and result mask)
1082 ;; Add all 8 bytes at once by multiplying with #256r11111111.
1083 ;; We need to calculate only the lower 8 bytes of the product.
1084 ;; Of these the most significant byte contains the final result.
1085 ;; Note that there can be no overflow from one byte to the next
1086 ;; as the sum is at most 64 which needs only 7 bits.
1087 (inst mov mask #x0101010101010101)
1088 (inst imul result mask)
1089 (inst shr result 56)))
1091 ;;;; binary conditional VOPs
1093 (define-vop (fast-conditional)
1098 (:policy :fast-safe))
1100 ;;; constant variants are declared for 32 bits not 64 bits, because
1101 ;;; loading a 64 bit constant is silly
1103 (define-vop (fast-conditional/fixnum fast-conditional)
1104 (:args (x :scs (any-reg)
1105 :load-if (not (and (sc-is x control-stack)
1106 (sc-is y any-reg))))
1107 (y :scs (any-reg control-stack)))
1108 (:arg-types tagged-num tagged-num)
1109 (:note "inline fixnum comparison"))
1111 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
1112 (:args (x :scs (any-reg)
1113 :load-if (or (not (typep y '(signed-byte 29)))
1114 (not (sc-is x any-reg control-stack)))))
1115 (:arg-types tagged-num (:constant fixnum))
1118 (define-vop (fast-conditional/signed fast-conditional)
1119 (:args (x :scs (signed-reg)
1120 :load-if (not (and (sc-is x signed-stack)
1121 (sc-is y signed-reg))))
1122 (y :scs (signed-reg signed-stack)))
1123 (:arg-types signed-num signed-num)
1124 (:note "inline (signed-byte 64) comparison"))
1126 (define-vop (fast-conditional-c/signed fast-conditional/signed)
1127 (:args (x :scs (signed-reg)
1128 :load-if (or (not (typep y '(signed-byte 32)))
1129 (not (sc-is x signed-reg signed-stack)))))
1130 (:arg-types signed-num (:constant (signed-byte 64)))
1133 (define-vop (fast-conditional/unsigned fast-conditional)
1134 (:args (x :scs (unsigned-reg)
1135 :load-if (not (and (sc-is x unsigned-stack)
1136 (sc-is y unsigned-reg))))
1137 (y :scs (unsigned-reg unsigned-stack)))
1138 (:arg-types unsigned-num unsigned-num)
1139 (:note "inline (unsigned-byte 64) comparison"))
1141 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
1142 (:args (x :scs (unsigned-reg)
1143 :load-if (or (not (typep y '(unsigned-byte 31)))
1144 (not (sc-is x unsigned-reg unsigned-stack)))))
1145 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
1148 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
1151 (lambda (suffix cost signed)
1152 `(define-vop (;; FIXME: These could be done more
1153 ;; cleanly with SYMBOLICATE.
1154 ,(intern (format nil "~:@(FAST-IF-~A~A~)"
1157 (format nil "~:@(FAST-CONDITIONAL~A~)"
1160 (:conditional ,(if signed cond unsigned))
1165 `(if (typep y '(signed-byte 29))
1167 (register-inline-constant
1168 :qword (fixnumize y))))
1170 `(if (typep y '(signed-byte 32))
1172 (register-inline-constant
1175 `(if (typep y '(unsigned-byte 31))
1177 (register-inline-constant
1180 '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
1181 ; '(/fixnum /signed /unsigned)
1183 '(t t t t nil nil)))))
1185 (define-conditional-vop < :l :b :ge :ae)
1186 (define-conditional-vop > :g :a :le :be))
1188 (define-vop (fast-if-eql/signed fast-conditional/signed)
1193 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
1196 (cond ((and (sc-is x signed-reg) (zerop y))
1197 (inst test x x)) ; smaller instruction
1198 ((typep y '(signed-byte 32))
1201 (inst cmp x (register-inline-constant :qword y))))))
1203 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
1208 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
1211 (cond ((and (sc-is x unsigned-reg) (zerop y))
1212 (inst test x x)) ; smaller instruction
1213 ((typep y '(unsigned-byte 31))
1216 (inst cmp x (register-inline-constant :qword y))))))
1218 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
1221 ;;; These versions specify a fixnum restriction on their first arg. We have
1222 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
1223 ;;; the first arg and a higher cost. The reason for doing this is to prevent
1224 ;;; fixnum specific operations from being used on word integers, spuriously
1225 ;;; consing the argument.
1227 (define-vop (fast-eql/fixnum fast-conditional)
1228 (:args (x :scs (any-reg)
1229 :load-if (not (and (sc-is x control-stack)
1230 (sc-is y any-reg))))
1231 (y :scs (any-reg control-stack)))
1232 (:arg-types tagged-num tagged-num)
1233 (:note "inline fixnum comparison")
1238 (define-vop (generic-eql/fixnum fast-eql/fixnum)
1239 (:args (x :scs (any-reg descriptor-reg)
1240 :load-if (not (and (sc-is x control-stack)
1241 (sc-is y any-reg))))
1242 (y :scs (any-reg control-stack)))
1243 (:arg-types * tagged-num)
1246 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
1247 (:args (x :scs (any-reg)
1248 :load-if (or (not (typep y '(signed-byte 29)))
1249 (not (sc-is x any-reg descriptor-reg control-stack)))))
1250 (:arg-types tagged-num (:constant fixnum))
1254 (cond ((and (sc-is x any-reg descriptor-reg) (zerop y))
1255 (inst test x x)) ; smaller instruction
1256 ((typep y '(signed-byte 29))
1257 (inst cmp x (fixnumize y)))
1259 (inst cmp x (register-inline-constant :qword (fixnumize y)))))))
1261 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
1262 (:args (x :scs (any-reg descriptor-reg)))
1263 (:arg-types * (:constant fixnum))
1266 ;;;; 32-bit logical operations
1268 ;;; Only the lower 6 bits of the shift amount are significant.
1269 (define-vop (shift-towards-someplace)
1270 (:policy :fast-safe)
1271 (:args (num :scs (unsigned-reg) :target r)
1272 (amount :scs (signed-reg) :target ecx))
1273 (:arg-types unsigned-num tagged-num)
1274 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
1275 (:results (r :scs (unsigned-reg) :from (:argument 0)))
1276 (:result-types unsigned-num))
1278 (define-vop (shift-towards-start shift-towards-someplace)
1279 (:translate shift-towards-start)
1280 (:note "SHIFT-TOWARDS-START")
1286 (define-vop (shift-towards-end shift-towards-someplace)
1287 (:translate shift-towards-end)
1288 (:note "SHIFT-TOWARDS-END")
1294 ;;;; Modular functions
1296 (defmacro define-mod-binop ((name prototype) function)
1297 `(define-vop (,name ,prototype)
1298 (:args (x :target r :scs (unsigned-reg signed-reg)
1299 :load-if (not (and (or (sc-is x unsigned-stack)
1300 (sc-is x signed-stack))
1301 (or (sc-is y unsigned-reg)
1302 (sc-is y signed-reg))
1303 (or (sc-is r unsigned-stack)
1304 (sc-is r signed-stack))
1306 (y :scs (unsigned-reg signed-reg unsigned-stack signed-stack)))
1307 (:arg-types untagged-num untagged-num)
1308 (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1309 :load-if (not (and (or (sc-is x unsigned-stack)
1310 (sc-is x signed-stack))
1311 (or (sc-is y unsigned-reg)
1312 (sc-is y unsigned-reg))
1313 (or (sc-is r unsigned-stack)
1314 (sc-is r unsigned-stack))
1316 (:result-types unsigned-num)
1317 (:translate ,function)))
1318 (defmacro define-mod-binop-c ((name prototype) function)
1319 `(define-vop (,name ,prototype)
1320 (:args (x :target r :scs (unsigned-reg signed-reg)
1321 :load-if (not (and (or (sc-is x unsigned-stack)
1322 (sc-is x signed-stack))
1323 (or (sc-is r unsigned-stack)
1324 (sc-is r signed-stack))
1326 (typep y '(signed-byte 32))))))
1328 (:arg-types untagged-num (:constant (or (unsigned-byte 64) (signed-byte 64))))
1329 (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1330 :load-if (not (and (or (sc-is x unsigned-stack)
1331 (sc-is x signed-stack))
1332 (or (sc-is r unsigned-stack)
1333 (sc-is r unsigned-stack))
1335 (:result-types unsigned-num)
1336 (:translate ,function)))
1338 (macrolet ((def (name -c-p)
1339 (let ((fun64 (intern (format nil "~S-MOD64" name)))
1340 (vopu (intern (format nil "FAST-~S/UNSIGNED=>UNSIGNED" name)))
1341 (vopcu (intern (format nil "FAST-~S-C/UNSIGNED=>UNSIGNED" name)))
1342 (vopf (intern (format nil "FAST-~S/FIXNUM=>FIXNUM" name)))
1343 (vopcf (intern (format nil "FAST-~S-C/FIXNUM=>FIXNUM" name)))
1344 (vop64u (intern (format nil "FAST-~S-MOD64/WORD=>UNSIGNED" name)))
1345 (vop64f (intern (format nil "FAST-~S-MOD64/FIXNUM=>FIXNUM" name)))
1346 (vop64cu (intern (format nil "FAST-~S-MOD64-C/WORD=>UNSIGNED" name)))
1347 (vop64cf (intern (format nil "FAST-~S-MOD64-C/FIXNUM=>FIXNUM" name)))
1348 (funfx (intern (format nil "~S-MODFX" name)))
1349 (vopfxf (intern (format nil "FAST-~S-MODFX/FIXNUM=>FIXNUM" name)))
1350 (vopfxcf (intern (format nil "FAST-~S-MODFX-C/FIXNUM=>FIXNUM" name))))
1352 (define-modular-fun ,fun64 (x y) ,name :untagged nil 64)
1353 (define-modular-fun ,funfx (x y) ,name :tagged t
1354 #.(- n-word-bits n-fixnum-tag-bits))
1355 (define-mod-binop (,vop64u ,vopu) ,fun64)
1356 (define-vop (,vop64f ,vopf) (:translate ,fun64))
1357 (define-vop (,vopfxf ,vopf) (:translate ,funfx))
1359 `((define-mod-binop-c (,vop64cu ,vopcu) ,fun64)
1360 (define-vop (,vopfxcf ,vopcf) (:translate ,funfx))))))))
1365 (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
1366 fast-ash-c/unsigned=>unsigned)
1367 (:translate ash-left-mod64))
1368 (define-vop (fast-ash-left-mod64/unsigned=>unsigned
1369 fast-ash-left/unsigned=>unsigned))
1370 (deftransform ash-left-mod64 ((integer count)
1371 ((unsigned-byte 64) (unsigned-byte 6)))
1372 (when (sb!c::constant-lvar-p count)
1373 (sb!c::give-up-ir1-transform))
1374 '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
1376 (define-vop (fast-ash-left-modfx-c/fixnum=>fixnum
1377 fast-ash-c/fixnum=>fixnum)
1379 (:translate ash-left-modfx))
1380 (define-vop (fast-ash-left-modfx/fixnum=>fixnum
1381 fast-ash-left/fixnum=>fixnum))
1382 (deftransform ash-left-modfx ((integer count)
1383 (fixnum (unsigned-byte 6)))
1384 (when (sb!c::constant-lvar-p count)
1385 (sb!c::give-up-ir1-transform))
1386 '(%primitive fast-ash-left-modfx/fixnum=>fixnum integer count))
1390 (defknown sb!vm::%lea-mod64 (integer integer (member 1 2 4 8) (signed-byte 64))
1392 (foldable flushable movable))
1393 (defknown sb!vm::%lea-modfx (integer integer (member 1 2 4 8) (signed-byte 64))
1395 (foldable flushable movable))
1397 (define-modular-fun-optimizer %lea ((base index scale disp) :untagged nil :width width)
1398 (when (and (<= width 64)
1399 (constant-lvar-p scale)
1400 (constant-lvar-p disp))
1401 (cut-to-width base :untagged width nil)
1402 (cut-to-width index :untagged width nil)
1403 'sb!vm::%lea-mod64))
1404 (define-modular-fun-optimizer %lea ((base index scale disp) :tagged t :width width)
1405 (when (and (<= width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
1406 (constant-lvar-p scale)
1407 (constant-lvar-p disp))
1408 (cut-to-width base :tagged width t)
1409 (cut-to-width index :tagged width t)
1410 'sb!vm::%lea-modfx))
1414 (defun sb!vm::%lea-mod64 (base index scale disp)
1415 (ldb (byte 64 0) (%lea base index scale disp)))
1416 (defun sb!vm::%lea-modfx (base index scale disp)
1417 (mask-signed-field (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)
1418 (%lea base index scale disp))))
1421 (defun sb!vm::%lea-mod64 (base index scale disp)
1422 (let ((base (logand base #xffffffffffffffff))
1423 (index (logand index #xffffffffffffffff)))
1424 ;; can't use modular version of %LEA, as we only have VOPs for
1425 ;; constant SCALE and DISP.
1426 (ldb (byte 64 0) (+ base (* index scale) disp))))
1427 (defun sb!vm::%lea-modfx (base index scale disp)
1428 (let* ((fixnum-width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
1429 (base (mask-signed-field fixnum-width base))
1430 (index (mask-signed-field fixnum-width index)))
1431 ;; can't use modular version of %LEA, as we only have VOPs for
1432 ;; constant SCALE and DISP.
1433 (mask-signed-field fixnum-width (+ base (* index scale) disp)))))
1435 (in-package "SB!VM")
1437 (define-vop (%lea-mod64/unsigned=>unsigned
1438 %lea/unsigned=>unsigned)
1439 (:translate %lea-mod64))
1440 (define-vop (%lea-modfx/fixnum=>fixnum
1441 %lea/fixnum=>fixnum)
1442 (:translate %lea-modfx))
1444 ;;; logical operations
1445 (define-modular-fun lognot-mod64 (x) lognot :untagged nil 64)
1446 (define-vop (lognot-mod64/unsigned=>unsigned)
1447 (:translate lognot-mod64)
1448 (:args (x :scs (unsigned-reg unsigned-stack) :target r
1449 :load-if (not (and (sc-is x unsigned-stack)
1450 (sc-is r unsigned-stack)
1452 (:arg-types unsigned-num)
1453 (:results (r :scs (unsigned-reg)
1454 :load-if (not (and (sc-is x unsigned-stack)
1455 (sc-is r unsigned-stack)
1457 (:result-types unsigned-num)
1458 (:policy :fast-safe)
1463 (define-source-transform logeqv (&rest args)
1464 (if (oddp (length args))
1466 `(lognot (logxor ,@args))))
1467 (define-source-transform logandc1 (x y)
1468 `(logand (lognot ,x) ,y))
1469 (define-source-transform logandc2 (x y)
1470 `(logand ,x (lognot ,y)))
1471 (define-source-transform logorc1 (x y)
1472 `(logior (lognot ,x) ,y))
1473 (define-source-transform logorc2 (x y)
1474 `(logior ,x (lognot ,y)))
1475 (define-source-transform lognor (x y)
1476 `(lognot (logior ,x ,y)))
1477 (define-source-transform lognand (x y)
1478 `(lognot (logand ,x ,y)))
1482 (define-vop (bignum-length get-header-data)
1483 (:translate sb!bignum:%bignum-length)
1484 (:policy :fast-safe))
1486 (define-vop (bignum-set-length set-header-data)
1487 (:translate sb!bignum:%bignum-set-length)
1488 (:policy :fast-safe))
1490 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
1491 (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
1492 (define-full-reffer+offset bignum--ref-with-offset * bignum-digits-offset
1493 other-pointer-lowtag (unsigned-reg) unsigned-num
1494 sb!bignum:%bignum-ref-with-offset)
1495 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
1496 (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
1498 (define-vop (digit-0-or-plus)
1499 (:translate sb!bignum:%digit-0-or-plusp)
1500 (:policy :fast-safe)
1501 (:args (digit :scs (unsigned-reg)))
1502 (:arg-types unsigned-num)
1505 (inst or digit digit)))
1508 ;;; For add and sub with carry the sc of carry argument is any-reg so
1509 ;;; that it may be passed as a fixnum or word and thus may be 0, 1, or
1510 ;;; 8. This is easy to deal with and may save a fixnum-word
1512 (define-vop (add-w/carry)
1513 (:translate sb!bignum:%add-with-carry)
1514 (:policy :fast-safe)
1515 (:args (a :scs (unsigned-reg) :target result)
1516 (b :scs (unsigned-reg unsigned-stack) :to :eval)
1517 (c :scs (any-reg) :target temp))
1518 (:arg-types unsigned-num unsigned-num positive-fixnum)
1519 (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
1520 (:results (result :scs (unsigned-reg) :from (:argument 0))
1521 (carry :scs (unsigned-reg)))
1522 (:result-types unsigned-num positive-fixnum)
1526 (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
1529 (inst adc carry carry)))
1531 ;;; Note: the borrow is 1 for no borrow and 0 for a borrow, the opposite
1532 ;;; of the x86-64 convention.
1533 (define-vop (sub-w/borrow)
1534 (:translate sb!bignum:%subtract-with-borrow)
1535 (:policy :fast-safe)
1536 (:args (a :scs (unsigned-reg) :to :eval :target result)
1537 (b :scs (unsigned-reg unsigned-stack) :to :result)
1538 (c :scs (any-reg control-stack)))
1539 (:arg-types unsigned-num unsigned-num positive-fixnum)
1540 (:results (result :scs (unsigned-reg) :from :eval)
1541 (borrow :scs (unsigned-reg)))
1542 (:result-types unsigned-num positive-fixnum)
1544 (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
1548 (inst sbb borrow 0)))
1551 (define-vop (bignum-mult-and-add-3-arg)
1552 (:translate sb!bignum:%multiply-and-add)
1553 (:policy :fast-safe)
1554 (:args (x :scs (unsigned-reg) :target eax)
1555 (y :scs (unsigned-reg unsigned-stack))
1556 (carry-in :scs (unsigned-reg unsigned-stack)))
1557 (:arg-types unsigned-num unsigned-num unsigned-num)
1558 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1559 :to (:result 1) :target lo) eax)
1560 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1561 :to (:result 0) :target hi) edx)
1562 (:results (hi :scs (unsigned-reg))
1563 (lo :scs (unsigned-reg)))
1564 (:result-types unsigned-num unsigned-num)
1568 (inst add eax carry-in)
1573 (define-vop (bignum-mult-and-add-4-arg)
1574 (:translate sb!bignum:%multiply-and-add)
1575 (:policy :fast-safe)
1576 (:args (x :scs (unsigned-reg) :target eax)
1577 (y :scs (unsigned-reg unsigned-stack))
1578 (prev :scs (unsigned-reg unsigned-stack))
1579 (carry-in :scs (unsigned-reg unsigned-stack)))
1580 (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1581 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1582 :to (:result 1) :target lo) eax)
1583 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1584 :to (:result 0) :target hi) edx)
1585 (:results (hi :scs (unsigned-reg))
1586 (lo :scs (unsigned-reg)))
1587 (:result-types unsigned-num unsigned-num)
1593 (inst add eax carry-in)
1599 (define-vop (bignum-mult)
1600 (:translate sb!bignum:%multiply)
1601 (:policy :fast-safe)
1602 (:args (x :scs (unsigned-reg) :target eax)
1603 (y :scs (unsigned-reg unsigned-stack)))
1604 (:arg-types unsigned-num unsigned-num)
1605 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1606 :to (:result 1) :target lo) eax)
1607 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1608 :to (:result 0) :target hi) edx)
1609 (:results (hi :scs (unsigned-reg))
1610 (lo :scs (unsigned-reg)))
1611 (:result-types unsigned-num unsigned-num)
1618 #!+multiply-high-vops
1620 (:translate sb!kernel:%multiply-high)
1621 (:policy :fast-safe)
1622 (:args (x :scs (unsigned-reg) :target eax)
1623 (y :scs (unsigned-reg unsigned-stack)))
1624 (:arg-types unsigned-num unsigned-num)
1625 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0))
1627 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1628 :to (:result 0) :target hi) edx)
1629 (:results (hi :scs (unsigned-reg)))
1630 (:result-types unsigned-num)
1636 #!+multiply-high-vops
1637 (define-vop (mulhi/fx)
1638 (:translate sb!kernel:%multiply-high)
1639 (:policy :fast-safe)
1640 (:args (x :scs (any-reg) :target eax)
1641 (y :scs (unsigned-reg unsigned-stack)))
1642 (:arg-types positive-fixnum unsigned-num)
1643 (:temporary (:sc any-reg :offset eax-offset :from (:argument 0)) eax)
1644 (:temporary (:sc any-reg :offset edx-offset :from (:argument 1)
1645 :to (:result 0) :target hi) edx)
1646 (:results (hi :scs (any-reg)))
1647 (:result-types positive-fixnum)
1652 (inst and hi (lognot fixnum-tag-mask))))
1654 (define-vop (bignum-lognot lognot-mod64/unsigned=>unsigned)
1655 (:translate sb!bignum:%lognot))
1657 (define-vop (fixnum-to-digit)
1658 (:translate sb!bignum:%fixnum-to-digit)
1659 (:policy :fast-safe)
1660 (:args (fixnum :scs (any-reg control-stack) :target digit))
1661 (:arg-types tagged-num)
1662 (:results (digit :scs (unsigned-reg)
1663 :load-if (not (and (sc-is fixnum control-stack)
1664 (sc-is digit unsigned-stack)
1665 (location= fixnum digit)))))
1666 (:result-types unsigned-num)
1669 (inst sar digit n-fixnum-tag-bits)))
1671 (define-vop (bignum-floor)
1672 (:translate sb!bignum:%bigfloor)
1673 (:policy :fast-safe)
1674 (:args (div-high :scs (unsigned-reg) :target edx)
1675 (div-low :scs (unsigned-reg) :target eax)
1676 (divisor :scs (unsigned-reg unsigned-stack)))
1677 (:arg-types unsigned-num unsigned-num unsigned-num)
1678 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
1679 :to (:result 0) :target quo) eax)
1680 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
1681 :to (:result 1) :target rem) edx)
1682 (:results (quo :scs (unsigned-reg))
1683 (rem :scs (unsigned-reg)))
1684 (:result-types unsigned-num unsigned-num)
1688 (inst div eax divisor)
1692 (define-vop (signify-digit)
1693 (:translate sb!bignum:%fixnum-digit-with-correct-sign)
1694 (:policy :fast-safe)
1695 (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
1696 (:arg-types unsigned-num)
1697 (:results (res :scs (any-reg signed-reg)
1698 :load-if (not (and (sc-is digit unsigned-stack)
1699 (sc-is res control-stack signed-stack)
1700 (location= digit res)))))
1701 (:result-types signed-num)
1704 (when (sc-is res any-reg control-stack)
1705 (inst shl res n-fixnum-tag-bits))))
1707 (define-vop (digit-ashr)
1708 (:translate sb!bignum:%ashr)
1709 (:policy :fast-safe)
1710 (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
1711 (count :scs (unsigned-reg) :target ecx))
1712 (:arg-types unsigned-num positive-fixnum)
1713 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
1714 (:results (result :scs (unsigned-reg) :from (:argument 0)
1715 :load-if (not (and (sc-is result unsigned-stack)
1716 (location= digit result)))))
1717 (:result-types unsigned-num)
1721 (inst sar result :cl)))
1723 (define-vop (digit-ashr/c)
1724 (:translate sb!bignum:%ashr)
1725 (:policy :fast-safe)
1726 (:args (digit :scs (unsigned-reg unsigned-stack) :target result))
1727 (:arg-types unsigned-num (:constant (integer 0 63)))
1729 (:results (result :scs (unsigned-reg) :from (:argument 0)
1730 :load-if (not (and (sc-is result unsigned-stack)
1731 (location= digit result)))))
1732 (:result-types unsigned-num)
1735 (inst sar result count)))
1737 (define-vop (digit-lshr digit-ashr)
1738 (:translate sb!bignum:%digit-logical-shift-right)
1742 (inst shr result :cl)))
1744 (define-vop (digit-ashl digit-ashr)
1745 (:translate sb!bignum:%ashl)
1749 (inst shl result :cl)))
1751 ;;;; static functions
1753 (define-static-fun two-arg-/ (x y) :translate /)
1755 (define-static-fun two-arg-gcd (x y) :translate gcd)
1756 (define-static-fun two-arg-lcm (x y) :translate lcm)
1758 (define-static-fun two-arg-and (x y) :translate logand)
1759 (define-static-fun two-arg-ior (x y) :translate logior)
1760 (define-static-fun two-arg-xor (x y) :translate logxor)
1765 (defun *-transformer (y)
1767 ((= y (ash 1 (integer-length y)))
1768 ;; there's a generic transform for y = 2^k
1769 (give-up-ir1-transform))
1770 ((member y '(3 5 9))
1771 ;; we can do these multiplications directly using LEA
1772 `(%lea x x ,(1- y) 0))
1774 ;; A normal 64-bit multiplication takes 4 cycles on Athlon 64/Opteron.
1775 ;; Optimizing multiplications (other than the above cases) to
1776 ;; shifts/adds/leas gives a maximum improvement of 1 cycle, but requires
1777 ;; quite a lot of hairy code.
1778 (give-up-ir1-transform))))
1780 (deftransform * ((x y)
1781 ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1783 "recode as leas, shifts and adds"
1784 (let ((y (lvar-value y)))
1786 (deftransform sb!vm::*-mod64
1787 ((x y) ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1789 "recode as leas, shifts and adds"
1790 (let ((y (lvar-value y)))
1793 (deftransform * ((x y)
1794 (fixnum (constant-arg (unsigned-byte 64)))
1796 "recode as leas, shifts and adds"
1797 (let ((y (lvar-value y)))
1799 (deftransform sb!vm::*-modfx
1800 ((x y) (fixnum (constant-arg (unsigned-byte 64)))
1802 "recode as leas, shifts and adds"
1803 (let ((y (lvar-value y)))