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")
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-SMOD61, so
685 (inst shl result amount)
687 (inst sar result (- amount))
688 (inst and result (lognot fixnum-tag-mask)))))
691 (aver (not "Impossible: fixnum ASH should not be called with
692 constant shift greater than word length")))
693 (if (sc-is result any-reg)
695 (inst mov result 0)))
696 (t (inst sar result 63)
697 (inst and result (lognot fixnum-tag-mask))))))))
699 (define-vop (fast-ash-left/fixnum=>fixnum)
701 (:args (number :scs (any-reg) :target result
702 :load-if (not (and (sc-is number control-stack)
703 (sc-is result control-stack)
704 (location= number result))))
705 (amount :scs (unsigned-reg) :target ecx))
706 (:arg-types tagged-num positive-fixnum)
707 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
708 (:results (result :scs (any-reg) :from (:argument 0)
709 :load-if (not (and (sc-is number control-stack)
710 (sc-is result control-stack)
711 (location= number result)))))
712 (:result-types tagged-num)
718 ;; The result-type ensures us that this shift will not overflow.
719 (inst shl result :cl)))
721 (define-vop (fast-ash-c/signed=>signed)
724 (:args (number :scs (signed-reg) :target result
725 :load-if (not (and (sc-is number signed-stack)
726 (sc-is result signed-stack)
727 (location= number result)))))
729 (:arg-types signed-num (:constant integer))
730 (:results (result :scs (signed-reg)
731 :load-if (not (and (sc-is number signed-stack)
732 (sc-is result signed-stack)
733 (location= number result)))))
734 (:result-types signed-num)
737 (cond ((and (= amount 1) (not (location= number result)))
738 (inst lea result (make-ea :qword :base number :index number)))
739 ((and (= amount 2) (not (location= number result)))
740 (inst lea result (make-ea :qword :index number :scale 4)))
741 ((and (= amount 3) (not (location= number result)))
742 (inst lea result (make-ea :qword :index number :scale 8)))
745 (cond ((plusp amount) (inst shl result amount))
746 (t (inst sar result (min 63 (- amount)))))))))
748 (define-vop (fast-ash-c/unsigned=>unsigned)
751 (:args (number :scs (unsigned-reg) :target result
752 :load-if (not (and (sc-is number unsigned-stack)
753 (sc-is result unsigned-stack)
754 (location= number result)))))
756 (:arg-types unsigned-num (:constant integer))
757 (:results (result :scs (unsigned-reg)
758 :load-if (not (and (sc-is number unsigned-stack)
759 (sc-is result unsigned-stack)
760 (location= number result)))))
761 (:result-types unsigned-num)
764 (cond ((and (= amount 1) (not (location= number result)))
765 (inst lea result (make-ea :qword :base number :index number)))
766 ((and (= amount 2) (not (location= number result)))
767 (inst lea result (make-ea :qword :index number :scale 4)))
768 ((and (= amount 3) (not (location= number result)))
769 (inst lea result (make-ea :qword :index number :scale 8)))
772 (cond ((< -64 amount 64) ;; XXXX
773 ;; this code is used both in ASH and ASH-MOD32, so
776 (inst shl result amount)
777 (inst shr result (- amount))))
778 (t (if (sc-is result unsigned-reg)
780 (inst mov result 0))))))))
782 (define-vop (fast-ash-left/signed=>signed)
784 (:args (number :scs (signed-reg) :target result
785 :load-if (not (and (sc-is number signed-stack)
786 (sc-is result signed-stack)
787 (location= number result))))
788 (amount :scs (unsigned-reg) :target ecx))
789 (:arg-types signed-num positive-fixnum)
790 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
791 (:results (result :scs (signed-reg) :from (:argument 0)
792 :load-if (not (and (sc-is number signed-stack)
793 (sc-is result signed-stack)
794 (location= number result)))))
795 (:result-types signed-num)
801 (inst shl result :cl)))
803 (define-vop (fast-ash-left/unsigned=>unsigned)
805 (:args (number :scs (unsigned-reg) :target result
806 :load-if (not (and (sc-is number unsigned-stack)
807 (sc-is result unsigned-stack)
808 (location= number result))))
809 (amount :scs (unsigned-reg) :target ecx))
810 (:arg-types unsigned-num positive-fixnum)
811 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
812 (:results (result :scs (unsigned-reg) :from (:argument 0)
813 :load-if (not (and (sc-is number unsigned-stack)
814 (sc-is result unsigned-stack)
815 (location= number result)))))
816 (:result-types unsigned-num)
822 (inst shl result :cl)))
824 (define-vop (fast-ash/signed=>signed)
827 (:args (number :scs (signed-reg) :target result)
828 (amount :scs (signed-reg) :target ecx))
829 (:arg-types signed-num signed-num)
830 (:results (result :scs (signed-reg) :from (:argument 0)))
831 (:result-types signed-num)
832 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
838 (inst jmp :ns POSITIVE)
844 (inst sar result :cl)
848 ;; The result-type ensures us that this shift will not overflow.
849 (inst shl result :cl)
853 (define-vop (fast-ash/unsigned=>unsigned)
856 (:args (number :scs (unsigned-reg) :target result)
857 (amount :scs (signed-reg) :target ecx))
858 (:arg-types unsigned-num signed-num)
859 (:results (result :scs (unsigned-reg) :from (:argument 0)))
860 (:result-types unsigned-num)
861 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
867 (inst jmp :ns POSITIVE)
874 (inst shr result :cl)
878 ;; The result-type ensures us that this shift will not overflow.
879 (inst shl result :cl)
885 (defknown %lea (integer integer (member 1 2 4 8 16) (signed-byte 64))
887 (foldable flushable movable))
889 (defoptimizer (%lea derive-type) ((base index scale disp))
890 (when (and (constant-lvar-p scale)
891 (constant-lvar-p disp))
892 (let ((scale (lvar-value scale))
893 (disp (lvar-value disp))
894 (base-type (lvar-type base))
895 (index-type (lvar-type index)))
896 (when (and (numeric-type-p base-type)
897 (numeric-type-p index-type))
898 (let ((base-lo (numeric-type-low base-type))
899 (base-hi (numeric-type-high base-type))
900 (index-lo (numeric-type-low index-type))
901 (index-hi (numeric-type-high index-type)))
902 (make-numeric-type :class 'integer
904 :low (when (and base-lo index-lo)
905 (+ base-lo (* index-lo scale) disp))
906 :high (when (and base-hi index-hi)
907 (+ base-hi (* index-hi scale) disp))))))))
909 (defun %lea (base index scale disp)
910 (+ base (* index scale) disp))
914 (define-vop (%lea/unsigned=>unsigned)
917 (:args (base :scs (unsigned-reg))
918 (index :scs (unsigned-reg)))
920 (:arg-types unsigned-num unsigned-num
921 (:constant (member 1 2 4 8))
922 (:constant (signed-byte 64)))
923 (:results (r :scs (unsigned-reg)))
924 (:result-types unsigned-num)
926 (inst lea r (make-ea :qword :base base :index index
927 :scale scale :disp disp))))
929 (define-vop (%lea/signed=>signed)
932 (:args (base :scs (signed-reg))
933 (index :scs (signed-reg)))
935 (:arg-types signed-num signed-num
936 (:constant (member 1 2 4 8))
937 (:constant (signed-byte 64)))
938 (:results (r :scs (signed-reg)))
939 (:result-types signed-num)
941 (inst lea r (make-ea :qword :base base :index index
942 :scale scale :disp disp))))
944 (define-vop (%lea/fixnum=>fixnum)
947 (:args (base :scs (any-reg))
948 (index :scs (any-reg)))
950 (:arg-types tagged-num tagged-num
951 (:constant (member 1 2 4 8))
952 (:constant (signed-byte 64)))
953 (:results (r :scs (any-reg)))
954 (:result-types tagged-num)
956 (inst lea r (make-ea :qword :base base :index index
957 :scale scale :disp disp))))
959 ;;; FIXME: before making knowledge of this too public, it needs to be
960 ;;; fixed so that it's actually _faster_ than the non-CMOV version; at
961 ;;; least on my Celeron-XXX laptop, this version is marginally slower
962 ;;; than the above version with branches. -- CSR, 2003-09-04
963 (define-vop (fast-cmov-ash/unsigned=>unsigned)
966 (:args (number :scs (unsigned-reg) :target result)
967 (amount :scs (signed-reg) :target ecx))
968 (:arg-types unsigned-num signed-num)
969 (:results (result :scs (unsigned-reg) :from (:argument 0)))
970 (:result-types unsigned-num)
971 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
972 (:temporary (:sc any-reg :from (:eval 0) :to (:eval 1)) zero)
974 (:guard (member :cmov *backend-subfeatures*))
979 (inst jmp :ns POSITIVE)
982 (inst shr result :cl)
984 (inst cmov :nbe result zero)
988 ;; The result-type ensures us that this shift will not overflow.
989 (inst shl result :cl)
993 (define-vop (signed-byte-64-len)
994 (:translate integer-length)
995 (:note "inline (signed-byte 64) integer-length")
997 (:args (arg :scs (signed-reg) :target res))
998 (:arg-types signed-num)
999 (:results (res :scs (unsigned-reg)))
1000 (:result-types unsigned-num)
1003 (if (sc-is res unsigned-reg)
1017 (define-vop (unsigned-byte-64-len)
1018 (:translate integer-length)
1019 (:note "inline (unsigned-byte 64) integer-length")
1020 (:policy :fast-safe)
1021 (:args (arg :scs (unsigned-reg)))
1022 (:arg-types unsigned-num)
1023 (:results (res :scs (unsigned-reg)))
1024 (:result-types unsigned-num)
1034 (define-vop (unsigned-byte-64-count)
1035 (:translate logcount)
1036 (:note "inline (unsigned-byte 64) logcount")
1037 (:policy :fast-safe)
1038 (:args (arg :scs (unsigned-reg) :target result))
1039 (:arg-types unsigned-num)
1040 (:results (result :scs (unsigned-reg)))
1041 (:result-types positive-fixnum)
1042 (:temporary (:sc unsigned-reg) temp)
1043 (:temporary (:sc unsigned-reg) mask)
1045 ;; See the comments below for how the algorithm works. The tricks
1046 ;; used can be found for example in AMD's software optimization
1047 ;; guide or at "http://www.hackersdelight.org/HDcode/pop.cc" in the
1048 ;; function "pop1", for 32-bit words. The extension to 64 bits is
1050 ;; Calculate 2-bit sums. Note that the value of a two-digit binary
1051 ;; number is the sum of the right digit and twice the left digit.
1052 ;; Thus we can calculate the sum of the two digits by shifting the
1053 ;; left digit to the right position and doing a two-bit subtraction.
1054 ;; This subtraction will never create a borrow and thus can be made
1055 ;; on all 32 2-digit numbers at once.
1059 (inst mov mask #x5555555555555555)
1060 (inst and result mask)
1061 (inst sub temp result)
1062 ;; Calculate 4-bit sums by straightforward shift, mask and add.
1063 ;; Note that we shift the source operand of the MOV and not its
1064 ;; destination so that the SHR and the MOV can execute in the same
1066 (inst mov result temp)
1068 (inst mov mask #x3333333333333333)
1069 (inst and result mask)
1070 (inst and temp mask)
1071 (inst add result temp)
1072 ;; Calculate 8-bit sums. Since each sum is at most 8, which fits
1073 ;; into 4 bits, we can apply the mask after the addition, saving one
1075 (inst mov temp result)
1077 (inst add result temp)
1078 (inst mov mask #x0f0f0f0f0f0f0f0f)
1079 (inst and result mask)
1080 ;; Add all 8 bytes at once by multiplying with #256r11111111.
1081 ;; We need to calculate only the lower 8 bytes of the product.
1082 ;; Of these the most significant byte contains the final result.
1083 ;; Note that there can be no overflow from one byte to the next
1084 ;; as the sum is at most 64 which needs only 7 bits.
1085 (inst mov mask #x0101010101010101)
1086 (inst imul result mask)
1087 (inst shr result 56)))
1089 ;;;; binary conditional VOPs
1091 (define-vop (fast-conditional)
1096 (:policy :fast-safe))
1098 ;;; constant variants are declared for 32 bits not 64 bits, because
1099 ;;; loading a 64 bit constant is silly
1101 (define-vop (fast-conditional/fixnum fast-conditional)
1102 (:args (x :scs (any-reg)
1103 :load-if (not (and (sc-is x control-stack)
1104 (sc-is y any-reg))))
1105 (y :scs (any-reg control-stack)))
1106 (:arg-types tagged-num tagged-num)
1107 (:note "inline fixnum comparison"))
1109 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
1110 (:args (x :scs (any-reg)
1111 :load-if (or (not (typep y '(signed-byte 29)))
1112 (not (sc-is x any-reg control-stack)))))
1113 (:arg-types tagged-num (:constant fixnum))
1116 (define-vop (fast-conditional/signed fast-conditional)
1117 (:args (x :scs (signed-reg)
1118 :load-if (not (and (sc-is x signed-stack)
1119 (sc-is y signed-reg))))
1120 (y :scs (signed-reg signed-stack)))
1121 (:arg-types signed-num signed-num)
1122 (:note "inline (signed-byte 64) comparison"))
1124 (define-vop (fast-conditional-c/signed fast-conditional/signed)
1125 (:args (x :scs (signed-reg)
1126 :load-if (or (not (typep y '(signed-byte 32)))
1127 (not (sc-is x signed-reg signed-stack)))))
1128 (:arg-types signed-num (:constant (signed-byte 64)))
1131 (define-vop (fast-conditional/unsigned fast-conditional)
1132 (:args (x :scs (unsigned-reg)
1133 :load-if (not (and (sc-is x unsigned-stack)
1134 (sc-is y unsigned-reg))))
1135 (y :scs (unsigned-reg unsigned-stack)))
1136 (:arg-types unsigned-num unsigned-num)
1137 (:note "inline (unsigned-byte 64) comparison"))
1139 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
1140 (:args (x :scs (unsigned-reg)
1141 :load-if (or (not (typep y '(unsigned-byte 31)))
1142 (not (sc-is x unsigned-reg unsigned-stack)))))
1143 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
1146 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
1149 (lambda (suffix cost signed)
1150 `(define-vop (;; FIXME: These could be done more
1151 ;; cleanly with SYMBOLICATE.
1152 ,(intern (format nil "~:@(FAST-IF-~A~A~)"
1155 (format nil "~:@(FAST-CONDITIONAL~A~)"
1158 (:conditional ,(if signed cond unsigned))
1163 `(if (typep y '(signed-byte 29))
1165 (register-inline-constant
1166 :qword (fixnumize y))))
1168 `(if (typep y '(signed-byte 32))
1170 (register-inline-constant
1173 `(if (typep y '(unsigned-byte 31))
1175 (register-inline-constant
1178 '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
1179 ; '(/fixnum /signed /unsigned)
1181 '(t t t t nil nil)))))
1183 (define-conditional-vop < :l :b :ge :ae)
1184 (define-conditional-vop > :g :a :le :be))
1186 (define-vop (fast-if-eql/signed fast-conditional/signed)
1191 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
1194 (cond ((and (sc-is x signed-reg) (zerop y))
1195 (inst test x x)) ; smaller instruction
1196 ((typep y '(signed-byte 32))
1199 (inst cmp x (register-inline-constant :qword y))))))
1201 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
1206 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
1209 (cond ((and (sc-is x unsigned-reg) (zerop y))
1210 (inst test x x)) ; smaller instruction
1211 ((typep y '(unsigned-byte 31))
1214 (inst cmp x (register-inline-constant :qword y))))))
1216 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
1219 ;;; These versions specify a fixnum restriction on their first arg. We have
1220 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
1221 ;;; the first arg and a higher cost. The reason for doing this is to prevent
1222 ;;; fixnum specific operations from being used on word integers, spuriously
1223 ;;; consing the argument.
1225 (define-vop (fast-eql/fixnum fast-conditional)
1226 (:args (x :scs (any-reg)
1227 :load-if (not (and (sc-is x control-stack)
1228 (sc-is y any-reg))))
1229 (y :scs (any-reg control-stack)))
1230 (:arg-types tagged-num tagged-num)
1231 (:note "inline fixnum comparison")
1236 (define-vop (generic-eql/fixnum fast-eql/fixnum)
1237 (:args (x :scs (any-reg descriptor-reg)
1238 :load-if (not (and (sc-is x control-stack)
1239 (sc-is y any-reg))))
1240 (y :scs (any-reg control-stack)))
1241 (:arg-types * tagged-num)
1244 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
1245 (:args (x :scs (any-reg)
1246 :load-if (or (not (typep y '(signed-byte 29)))
1247 (not (sc-is x any-reg descriptor-reg control-stack)))))
1248 (:arg-types tagged-num (:constant fixnum))
1252 (cond ((and (sc-is x any-reg descriptor-reg) (zerop y))
1253 (inst test x x)) ; smaller instruction
1254 ((typep y '(signed-byte 29))
1255 (inst cmp x (fixnumize y)))
1257 (inst cmp x (register-inline-constant :qword (fixnumize y)))))))
1259 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
1260 (:args (x :scs (any-reg descriptor-reg)))
1261 (:arg-types * (:constant fixnum))
1264 ;;;; 32-bit logical operations
1266 ;;; Only the lower 6 bits of the shift amount are significant.
1267 (define-vop (shift-towards-someplace)
1268 (:policy :fast-safe)
1269 (:args (num :scs (unsigned-reg) :target r)
1270 (amount :scs (signed-reg) :target ecx))
1271 (:arg-types unsigned-num tagged-num)
1272 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
1273 (:results (r :scs (unsigned-reg) :from (:argument 0)))
1274 (:result-types unsigned-num))
1276 (define-vop (shift-towards-start shift-towards-someplace)
1277 (:translate shift-towards-start)
1278 (:note "SHIFT-TOWARDS-START")
1284 (define-vop (shift-towards-end shift-towards-someplace)
1285 (:translate shift-towards-end)
1286 (:note "SHIFT-TOWARDS-END")
1292 ;;;; Modular functions
1294 (defmacro define-mod-binop ((name prototype) function)
1295 `(define-vop (,name ,prototype)
1296 (:args (x :target r :scs (unsigned-reg signed-reg)
1297 :load-if (not (and (or (sc-is x unsigned-stack)
1298 (sc-is x signed-stack))
1299 (or (sc-is y unsigned-reg)
1300 (sc-is y signed-reg))
1301 (or (sc-is r unsigned-stack)
1302 (sc-is r signed-stack))
1304 (y :scs (unsigned-reg signed-reg unsigned-stack signed-stack)))
1305 (:arg-types untagged-num untagged-num)
1306 (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1307 :load-if (not (and (or (sc-is x unsigned-stack)
1308 (sc-is x signed-stack))
1309 (or (sc-is y unsigned-reg)
1310 (sc-is y unsigned-reg))
1311 (or (sc-is r unsigned-stack)
1312 (sc-is r unsigned-stack))
1314 (:result-types unsigned-num)
1315 (:translate ,function)))
1316 (defmacro define-mod-binop-c ((name prototype) function)
1317 `(define-vop (,name ,prototype)
1318 (:args (x :target r :scs (unsigned-reg signed-reg)
1319 :load-if (not (and (or (sc-is x unsigned-stack)
1320 (sc-is x signed-stack))
1321 (or (sc-is r unsigned-stack)
1322 (sc-is r signed-stack))
1324 (typep y '(signed-byte 32))))))
1326 (:arg-types untagged-num (:constant (or (unsigned-byte 64) (signed-byte 64))))
1327 (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1328 :load-if (not (and (or (sc-is x unsigned-stack)
1329 (sc-is x signed-stack))
1330 (or (sc-is r unsigned-stack)
1331 (sc-is r unsigned-stack))
1333 (:result-types unsigned-num)
1334 (:translate ,function)))
1336 (macrolet ((def (name -c-p)
1337 (let ((fun64 (intern (format nil "~S-MOD64" name)))
1338 (vopu (intern (format nil "FAST-~S/UNSIGNED=>UNSIGNED" name)))
1339 (vopcu (intern (format nil "FAST-~S-C/UNSIGNED=>UNSIGNED" name)))
1340 (vopf (intern (format nil "FAST-~S/FIXNUM=>FIXNUM" name)))
1341 (vopcf (intern (format nil "FAST-~S-C/FIXNUM=>FIXNUM" name)))
1342 (vop64u (intern (format nil "FAST-~S-MOD64/WORD=>UNSIGNED" name)))
1343 (vop64f (intern (format nil "FAST-~S-MOD64/FIXNUM=>FIXNUM" name)))
1344 (vop64cu (intern (format nil "FAST-~S-MOD64-C/WORD=>UNSIGNED" name)))
1345 (vop64cf (intern (format nil "FAST-~S-MOD64-C/FIXNUM=>FIXNUM" name)))
1346 (sfun61 (intern (format nil "~S-SMOD61" name)))
1347 (svop61f (intern (format nil "FAST-~S-SMOD61/FIXNUM=>FIXNUM" name)))
1348 (svop61cf (intern (format nil "FAST-~S-SMOD61-C/FIXNUM=>FIXNUM" name))))
1350 (define-modular-fun ,fun64 (x y) ,name :untagged nil 64)
1351 (define-modular-fun ,sfun61 (x y) ,name :tagged t 61)
1352 (define-mod-binop (,vop64u ,vopu) ,fun64)
1353 (define-vop (,vop64f ,vopf) (:translate ,fun64))
1354 (define-vop (,svop61f ,vopf) (:translate ,sfun61))
1356 `((define-mod-binop-c (,vop64cu ,vopcu) ,fun64)
1357 (define-vop (,svop61cf ,vopcf) (:translate ,sfun61))))))))
1362 (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
1363 fast-ash-c/unsigned=>unsigned)
1364 (:translate ash-left-mod64))
1365 (define-vop (fast-ash-left-mod64/unsigned=>unsigned
1366 fast-ash-left/unsigned=>unsigned))
1367 (deftransform ash-left-mod64 ((integer count)
1368 ((unsigned-byte 64) (unsigned-byte 6)))
1369 (when (sb!c::constant-lvar-p count)
1370 (sb!c::give-up-ir1-transform))
1371 '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
1373 (define-vop (fast-ash-left-smod61-c/fixnum=>fixnum
1374 fast-ash-c/fixnum=>fixnum)
1376 (:translate ash-left-smod61))
1377 (define-vop (fast-ash-left-smod61/fixnum=>fixnum
1378 fast-ash-left/fixnum=>fixnum))
1379 (deftransform ash-left-smod61 ((integer count)
1380 ((signed-byte 61) (unsigned-byte 6)))
1381 (when (sb!c::constant-lvar-p count)
1382 (sb!c::give-up-ir1-transform))
1383 '(%primitive fast-ash-left-smod61/fixnum=>fixnum integer count))
1387 (defknown sb!vm::%lea-mod64 (integer integer (member 1 2 4 8) (signed-byte 64))
1389 (foldable flushable movable))
1390 (defknown sb!vm::%lea-smod61 (integer integer (member 1 2 4 8) (signed-byte 64))
1392 (foldable flushable movable))
1394 (define-modular-fun-optimizer %lea ((base index scale disp) :untagged nil :width width)
1395 (when (and (<= width 64)
1396 (constant-lvar-p scale)
1397 (constant-lvar-p disp))
1398 (cut-to-width base :untagged width nil)
1399 (cut-to-width index :untagged width nil)
1400 'sb!vm::%lea-mod64))
1401 (define-modular-fun-optimizer %lea ((base index scale disp) :tagged t :width width)
1402 (when (and (<= width 61)
1403 (constant-lvar-p scale)
1404 (constant-lvar-p disp))
1405 (cut-to-width base :tagged width t)
1406 (cut-to-width index :tagged width t)
1407 'sb!vm::%lea-smod61))
1411 (defun sb!vm::%lea-mod64 (base index scale disp)
1412 (ldb (byte 64 0) (%lea base index scale disp)))
1413 (defun sb!vm::%lea-smod61 (base index scale disp)
1414 (mask-signed-field 61 (%lea base index scale disp))))
1417 (defun sb!vm::%lea-mod64 (base index scale disp)
1418 (let ((base (logand base #xffffffffffffffff))
1419 (index (logand index #xffffffffffffffff)))
1420 ;; can't use modular version of %LEA, as we only have VOPs for
1421 ;; constant SCALE and DISP.
1422 (ldb (byte 64 0) (+ base (* index scale) disp))))
1423 (defun sb!vm::%lea-smod61 (base index scale disp)
1424 (let ((base (mask-signed-field 61 base))
1425 (index (mask-signed-field 61 index)))
1426 ;; can't use modular version of %LEA, as we only have VOPs for
1427 ;; constant SCALE and DISP.
1428 (mask-signed-field 61 (+ base (* index scale) disp)))))
1430 (in-package "SB!VM")
1432 (define-vop (%lea-mod64/unsigned=>unsigned
1433 %lea/unsigned=>unsigned)
1434 (:translate %lea-mod64))
1435 (define-vop (%lea-smod61/fixnum=>fixnum
1436 %lea/fixnum=>fixnum)
1437 (:translate %lea-smod61))
1439 ;;; logical operations
1440 (define-modular-fun lognot-mod64 (x) lognot :untagged nil 64)
1441 (define-vop (lognot-mod64/unsigned=>unsigned)
1442 (:translate lognot-mod64)
1443 (:args (x :scs (unsigned-reg unsigned-stack) :target r
1444 :load-if (not (and (sc-is x unsigned-stack)
1445 (sc-is r unsigned-stack)
1447 (:arg-types unsigned-num)
1448 (:results (r :scs (unsigned-reg)
1449 :load-if (not (and (sc-is x unsigned-stack)
1450 (sc-is r unsigned-stack)
1452 (:result-types unsigned-num)
1453 (:policy :fast-safe)
1458 (define-source-transform logeqv (&rest args)
1459 (if (oddp (length args))
1461 `(lognot (logxor ,@args))))
1462 (define-source-transform logandc1 (x y)
1463 `(logand (lognot ,x) ,y))
1464 (define-source-transform logandc2 (x y)
1465 `(logand ,x (lognot ,y)))
1466 (define-source-transform logorc1 (x y)
1467 `(logior (lognot ,x) ,y))
1468 (define-source-transform logorc2 (x y)
1469 `(logior ,x (lognot ,y)))
1470 (define-source-transform lognor (x y)
1471 `(lognot (logior ,x ,y)))
1472 (define-source-transform lognand (x y)
1473 `(lognot (logand ,x ,y)))
1477 (define-vop (bignum-length get-header-data)
1478 (:translate sb!bignum:%bignum-length)
1479 (:policy :fast-safe))
1481 (define-vop (bignum-set-length set-header-data)
1482 (:translate sb!bignum:%bignum-set-length)
1483 (:policy :fast-safe))
1485 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
1486 (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
1487 (define-full-reffer+offset bignum--ref-with-offset * bignum-digits-offset
1488 other-pointer-lowtag (unsigned-reg) unsigned-num
1489 sb!bignum:%bignum-ref-with-offset)
1490 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
1491 (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
1493 (define-vop (digit-0-or-plus)
1494 (:translate sb!bignum:%digit-0-or-plusp)
1495 (:policy :fast-safe)
1496 (:args (digit :scs (unsigned-reg)))
1497 (:arg-types unsigned-num)
1500 (inst or digit digit)))
1503 ;;; For add and sub with carry the sc of carry argument is any-reg so
1504 ;;; that it may be passed as a fixnum or word and thus may be 0, 1, or
1505 ;;; 8. This is easy to deal with and may save a fixnum-word
1507 (define-vop (add-w/carry)
1508 (:translate sb!bignum:%add-with-carry)
1509 (:policy :fast-safe)
1510 (:args (a :scs (unsigned-reg) :target result)
1511 (b :scs (unsigned-reg unsigned-stack) :to :eval)
1512 (c :scs (any-reg) :target temp))
1513 (:arg-types unsigned-num unsigned-num positive-fixnum)
1514 (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
1515 (:results (result :scs (unsigned-reg) :from (:argument 0))
1516 (carry :scs (unsigned-reg)))
1517 (:result-types unsigned-num positive-fixnum)
1521 (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
1524 (inst adc carry carry)))
1526 ;;; Note: the borrow is 1 for no borrow and 0 for a borrow, the opposite
1527 ;;; of the x86-64 convention.
1528 (define-vop (sub-w/borrow)
1529 (:translate sb!bignum:%subtract-with-borrow)
1530 (:policy :fast-safe)
1531 (:args (a :scs (unsigned-reg) :to :eval :target result)
1532 (b :scs (unsigned-reg unsigned-stack) :to :result)
1533 (c :scs (any-reg control-stack)))
1534 (:arg-types unsigned-num unsigned-num positive-fixnum)
1535 (:results (result :scs (unsigned-reg) :from :eval)
1536 (borrow :scs (unsigned-reg)))
1537 (:result-types unsigned-num positive-fixnum)
1539 (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
1543 (inst sbb borrow 0)))
1546 (define-vop (bignum-mult-and-add-3-arg)
1547 (:translate sb!bignum:%multiply-and-add)
1548 (:policy :fast-safe)
1549 (:args (x :scs (unsigned-reg) :target eax)
1550 (y :scs (unsigned-reg unsigned-stack))
1551 (carry-in :scs (unsigned-reg unsigned-stack)))
1552 (:arg-types unsigned-num unsigned-num unsigned-num)
1553 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1554 :to (:result 1) :target lo) eax)
1555 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1556 :to (:result 0) :target hi) edx)
1557 (:results (hi :scs (unsigned-reg))
1558 (lo :scs (unsigned-reg)))
1559 (:result-types unsigned-num unsigned-num)
1563 (inst add eax carry-in)
1568 (define-vop (bignum-mult-and-add-4-arg)
1569 (:translate sb!bignum:%multiply-and-add)
1570 (:policy :fast-safe)
1571 (:args (x :scs (unsigned-reg) :target eax)
1572 (y :scs (unsigned-reg unsigned-stack))
1573 (prev :scs (unsigned-reg unsigned-stack))
1574 (carry-in :scs (unsigned-reg unsigned-stack)))
1575 (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1576 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1577 :to (:result 1) :target lo) eax)
1578 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1579 :to (:result 0) :target hi) edx)
1580 (:results (hi :scs (unsigned-reg))
1581 (lo :scs (unsigned-reg)))
1582 (:result-types unsigned-num unsigned-num)
1588 (inst add eax carry-in)
1594 (define-vop (bignum-mult)
1595 (:translate sb!bignum:%multiply)
1596 (:policy :fast-safe)
1597 (:args (x :scs (unsigned-reg) :target eax)
1598 (y :scs (unsigned-reg unsigned-stack)))
1599 (:arg-types unsigned-num unsigned-num)
1600 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1601 :to (:result 1) :target lo) eax)
1602 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1603 :to (:result 0) :target hi) edx)
1604 (:results (hi :scs (unsigned-reg))
1605 (lo :scs (unsigned-reg)))
1606 (:result-types unsigned-num unsigned-num)
1613 (define-vop (bignum-lognot lognot-mod64/unsigned=>unsigned)
1614 (:translate sb!bignum:%lognot))
1616 (define-vop (fixnum-to-digit)
1617 (:translate sb!bignum:%fixnum-to-digit)
1618 (:policy :fast-safe)
1619 (:args (fixnum :scs (any-reg control-stack) :target digit))
1620 (:arg-types tagged-num)
1621 (:results (digit :scs (unsigned-reg)
1622 :load-if (not (and (sc-is fixnum control-stack)
1623 (sc-is digit unsigned-stack)
1624 (location= fixnum digit)))))
1625 (:result-types unsigned-num)
1628 (inst sar digit 3)))
1630 (define-vop (bignum-floor)
1631 (:translate sb!bignum:%floor)
1632 (:policy :fast-safe)
1633 (:args (div-high :scs (unsigned-reg) :target edx)
1634 (div-low :scs (unsigned-reg) :target eax)
1635 (divisor :scs (unsigned-reg unsigned-stack)))
1636 (:arg-types unsigned-num unsigned-num unsigned-num)
1637 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
1638 :to (:result 0) :target quo) eax)
1639 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
1640 :to (:result 1) :target rem) edx)
1641 (:results (quo :scs (unsigned-reg))
1642 (rem :scs (unsigned-reg)))
1643 (:result-types unsigned-num unsigned-num)
1647 (inst div eax divisor)
1651 (define-vop (signify-digit)
1652 (:translate sb!bignum:%fixnum-digit-with-correct-sign)
1653 (:policy :fast-safe)
1654 (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
1655 (:arg-types unsigned-num)
1656 (:results (res :scs (any-reg signed-reg)
1657 :load-if (not (and (sc-is digit unsigned-stack)
1658 (sc-is res control-stack signed-stack)
1659 (location= digit res)))))
1660 (:result-types signed-num)
1663 (when (sc-is res any-reg control-stack)
1666 (define-vop (digit-ashr)
1667 (:translate sb!bignum:%ashr)
1668 (:policy :fast-safe)
1669 (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
1670 (count :scs (unsigned-reg) :target ecx))
1671 (:arg-types unsigned-num positive-fixnum)
1672 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
1673 (:results (result :scs (unsigned-reg) :from (:argument 0)
1674 :load-if (not (and (sc-is result unsigned-stack)
1675 (location= digit result)))))
1676 (:result-types unsigned-num)
1680 (inst sar result :cl)))
1682 (define-vop (digit-ashr/c)
1683 (:translate sb!bignum:%ashr)
1684 (:policy :fast-safe)
1685 (:args (digit :scs (unsigned-reg unsigned-stack) :target result))
1686 (:arg-types unsigned-num (:constant (integer 0 63)))
1688 (:results (result :scs (unsigned-reg) :from (:argument 0)
1689 :load-if (not (and (sc-is result unsigned-stack)
1690 (location= digit result)))))
1691 (:result-types unsigned-num)
1694 (inst sar result count)))
1696 (define-vop (digit-lshr digit-ashr)
1697 (:translate sb!bignum:%digit-logical-shift-right)
1701 (inst shr result :cl)))
1703 (define-vop (digit-ashl digit-ashr)
1704 (:translate sb!bignum:%ashl)
1708 (inst shl result :cl)))
1710 ;;;; static functions
1712 (define-static-fun two-arg-/ (x y) :translate /)
1714 (define-static-fun two-arg-gcd (x y) :translate gcd)
1715 (define-static-fun two-arg-lcm (x y) :translate lcm)
1717 (define-static-fun two-arg-and (x y) :translate logand)
1718 (define-static-fun two-arg-ior (x y) :translate logior)
1719 (define-static-fun two-arg-xor (x y) :translate logxor)
1724 (defun *-transformer (y)
1726 ((= y (ash 1 (integer-length y)))
1727 ;; there's a generic transform for y = 2^k
1728 (give-up-ir1-transform))
1729 ((member y '(3 5 9))
1730 ;; we can do these multiplications directly using LEA
1731 `(%lea x x ,(1- y) 0))
1733 ;; A normal 64-bit multiplication takes 4 cycles on Athlon 64/Opteron.
1734 ;; Optimizing multiplications (other than the above cases) to
1735 ;; shifts/adds/leas gives a maximum improvement of 1 cycle, but requires
1736 ;; quite a lot of hairy code.
1737 (give-up-ir1-transform))))
1739 (deftransform * ((x y)
1740 ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1742 "recode as leas, shifts and adds"
1743 (let ((y (lvar-value y)))
1745 (deftransform sb!vm::*-mod64
1746 ((x y) ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1748 "recode as leas, shifts and adds"
1749 (let ((y (lvar-value y)))
1752 (deftransform * ((x y)
1753 ((signed-byte 61) (constant-arg (unsigned-byte 64)))
1755 "recode as leas, shifts and adds"
1756 (let ((y (lvar-value y)))
1758 (deftransform sb!vm::*-smod61
1759 ((x y) ((signed-byte 61) (constant-arg (unsigned-byte 64)))
1761 "recode as leas, shifts and adds"
1762 (let ((y (lvar-value y)))