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)
513 (inst lea quo (make-ea :qword :index eax :scale 8)))
516 (define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
517 (:translate truncate)
518 (:args (x :scs (any-reg) :target eax))
520 (:arg-types tagged-num (:constant fixnum))
521 (:temporary (:sc signed-reg :offset eax-offset :target quo
522 :from :argument :to (:result 0)) eax)
523 (:temporary (:sc any-reg :offset edx-offset :target rem
524 :from :eval :to (:result 1)) edx)
525 (:temporary (:sc any-reg :from :eval :to :result) y-arg)
526 (:results (quo :scs (any-reg))
527 (rem :scs (any-reg)))
528 (:result-types tagged-num tagged-num)
529 (:note "inline fixnum arithmetic")
531 (:save-p :compute-only)
535 (if (typep y '(signed-byte 29))
536 (inst mov y-arg (fixnumize y))
537 (setf y-arg (register-inline-constant :qword (fixnumize y))))
538 (inst idiv eax y-arg)
539 (if (location= quo eax)
541 (inst lea quo (make-ea :qword :index eax :scale 8)))
544 (define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
545 (:translate truncate)
546 (:args (x :scs (unsigned-reg) :target eax)
547 (y :scs (unsigned-reg signed-stack)))
548 (:arg-types unsigned-num unsigned-num)
549 (:temporary (:sc unsigned-reg :offset eax-offset :target quo
550 :from (:argument 0) :to (:result 0)) eax)
551 (:temporary (:sc unsigned-reg :offset edx-offset :target rem
552 :from (:argument 0) :to (:result 1)) edx)
553 (:results (quo :scs (unsigned-reg))
554 (rem :scs (unsigned-reg)))
555 (:result-types unsigned-num unsigned-num)
556 (:note "inline (unsigned-byte 64) arithmetic")
558 (:save-p :compute-only)
560 (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
561 (if (sc-is y unsigned-reg)
562 (inst test y y) ; smaller instruction
571 (define-vop (fast-truncate-c/unsigned=>unsigned fast-safe-arith-op)
572 (:translate truncate)
573 (:args (x :scs (unsigned-reg) :target eax))
575 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
576 (:temporary (:sc unsigned-reg :offset eax-offset :target quo
577 :from :argument :to (:result 0)) eax)
578 (:temporary (:sc unsigned-reg :offset edx-offset :target rem
579 :from :eval :to (:result 1)) edx)
580 (:temporary (:sc unsigned-reg :from :eval :to :result) y-arg)
581 (:results (quo :scs (unsigned-reg))
582 (rem :scs (unsigned-reg)))
583 (:result-types unsigned-num unsigned-num)
584 (:note "inline (unsigned-byte 64) arithmetic")
586 (:save-p :compute-only)
590 (if (typep y '(unsigned-byte 31))
592 (setf y-arg (register-inline-constant :qword y)))
597 (define-vop (fast-truncate/signed=>signed fast-safe-arith-op)
598 (:translate truncate)
599 (:args (x :scs (signed-reg) :target eax)
600 (y :scs (signed-reg signed-stack)))
601 (:arg-types signed-num signed-num)
602 (:temporary (:sc signed-reg :offset eax-offset :target quo
603 :from (:argument 0) :to (:result 0)) eax)
604 (:temporary (:sc signed-reg :offset edx-offset :target rem
605 :from (:argument 0) :to (:result 1)) edx)
606 (:results (quo :scs (signed-reg))
607 (rem :scs (signed-reg)))
608 (:result-types signed-num signed-num)
609 (:note "inline (signed-byte 64) arithmetic")
611 (:save-p :compute-only)
613 (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
614 (if (sc-is y signed-reg)
615 (inst test y y) ; smaller instruction
624 (define-vop (fast-truncate-c/signed=>signed fast-safe-arith-op)
625 (:translate truncate)
626 (:args (x :scs (signed-reg) :target eax))
628 (:arg-types signed-num (:constant (signed-byte 64)))
629 (:temporary (:sc signed-reg :offset eax-offset :target quo
630 :from :argument :to (:result 0)) eax)
631 (:temporary (:sc signed-reg :offset edx-offset :target rem
632 :from :eval :to (:result 1)) edx)
633 (:temporary (:sc signed-reg :from :eval :to :result) y-arg)
634 (:results (quo :scs (signed-reg))
635 (rem :scs (signed-reg)))
636 (:result-types signed-num signed-num)
637 (:note "inline (signed-byte 64) arithmetic")
639 (:save-p :compute-only)
643 (if (typep y '(signed-byte 32))
645 (setf y-arg (register-inline-constant :qword y)))
646 (inst idiv eax y-arg)
653 (define-vop (fast-ash-c/fixnum=>fixnum)
656 (:args (number :scs (any-reg) :target result
657 :load-if (not (and (sc-is number any-reg control-stack)
658 (sc-is result any-reg control-stack)
659 (location= number result)))))
661 (:arg-types tagged-num (:constant integer))
662 (:results (result :scs (any-reg)
663 :load-if (not (and (sc-is number control-stack)
664 (sc-is result control-stack)
665 (location= number result)))))
666 (:result-types tagged-num)
669 (cond ((and (= amount 1) (not (location= number result)))
670 (inst lea result (make-ea :qword :base number :index number)))
671 ((and (= amount 2) (not (location= number result)))
672 (inst lea result (make-ea :qword :index number :scale 4)))
673 ((and (= amount 3) (not (location= number result)))
674 (inst lea result (make-ea :qword :index number :scale 8)))
677 (cond ((< -64 amount 64)
678 ;; this code is used both in ASH and ASH-SMOD61, so
681 (inst shl result amount)
683 (inst sar result (- amount))
684 (inst and result (lognot fixnum-tag-mask)))))
686 (if (sc-is result any-reg)
687 (inst xor result result)
688 (inst mov result 0)))
689 (t (inst sar result 63)
690 (inst and result (lognot fixnum-tag-mask))))))))
692 (define-vop (fast-ash-left/fixnum=>fixnum)
694 (:args (number :scs (any-reg) :target result
695 :load-if (not (and (sc-is number control-stack)
696 (sc-is result control-stack)
697 (location= number result))))
698 (amount :scs (unsigned-reg) :target ecx))
699 (:arg-types tagged-num positive-fixnum)
700 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
701 (:results (result :scs (any-reg) :from (:argument 0)
702 :load-if (not (and (sc-is number control-stack)
703 (sc-is result control-stack)
704 (location= number result)))))
705 (:result-types tagged-num)
711 ;; The result-type ensures us that this shift will not overflow.
712 (inst shl result :cl)))
714 (define-vop (fast-ash-c/signed=>signed)
717 (:args (number :scs (signed-reg) :target result
718 :load-if (not (and (sc-is number signed-stack)
719 (sc-is result signed-stack)
720 (location= number result)))))
722 (:arg-types signed-num (:constant integer))
723 (:results (result :scs (signed-reg)
724 :load-if (not (and (sc-is number signed-stack)
725 (sc-is result signed-stack)
726 (location= number result)))))
727 (:result-types signed-num)
730 (cond ((and (= amount 1) (not (location= number result)))
731 (inst lea result (make-ea :qword :base number :index number)))
732 ((and (= amount 2) (not (location= number result)))
733 (inst lea result (make-ea :qword :index number :scale 4)))
734 ((and (= amount 3) (not (location= number result)))
735 (inst lea result (make-ea :qword :index number :scale 8)))
738 (cond ((plusp amount) (inst shl result amount))
739 (t (inst sar result (min 63 (- amount)))))))))
741 (define-vop (fast-ash-c/unsigned=>unsigned)
744 (:args (number :scs (unsigned-reg) :target result
745 :load-if (not (and (sc-is number unsigned-stack)
746 (sc-is result unsigned-stack)
747 (location= number result)))))
749 (:arg-types unsigned-num (:constant integer))
750 (:results (result :scs (unsigned-reg)
751 :load-if (not (and (sc-is number unsigned-stack)
752 (sc-is result unsigned-stack)
753 (location= number result)))))
754 (:result-types unsigned-num)
757 (cond ((and (= amount 1) (not (location= number result)))
758 (inst lea result (make-ea :qword :base number :index number)))
759 ((and (= amount 2) (not (location= number result)))
760 (inst lea result (make-ea :qword :index number :scale 4)))
761 ((and (= amount 3) (not (location= number result)))
762 (inst lea result (make-ea :qword :index number :scale 8)))
765 (cond ((< -64 amount 64) ;; XXXX
766 ;; this code is used both in ASH and ASH-MOD32, so
769 (inst shl result amount)
770 (inst shr result (- amount))))
771 (t (if (sc-is result unsigned-reg)
773 (inst mov result 0))))))))
775 (define-vop (fast-ash-left/signed=>signed)
777 (:args (number :scs (signed-reg) :target result
778 :load-if (not (and (sc-is number signed-stack)
779 (sc-is result signed-stack)
780 (location= number result))))
781 (amount :scs (unsigned-reg) :target ecx))
782 (:arg-types signed-num positive-fixnum)
783 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
784 (:results (result :scs (signed-reg) :from (:argument 0)
785 :load-if (not (and (sc-is number signed-stack)
786 (sc-is result signed-stack)
787 (location= number result)))))
788 (:result-types signed-num)
794 (inst shl result :cl)))
796 (define-vop (fast-ash-left/unsigned=>unsigned)
798 (:args (number :scs (unsigned-reg) :target result
799 :load-if (not (and (sc-is number unsigned-stack)
800 (sc-is result unsigned-stack)
801 (location= number result))))
802 (amount :scs (unsigned-reg) :target ecx))
803 (:arg-types unsigned-num positive-fixnum)
804 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
805 (:results (result :scs (unsigned-reg) :from (:argument 0)
806 :load-if (not (and (sc-is number unsigned-stack)
807 (sc-is result unsigned-stack)
808 (location= number result)))))
809 (:result-types unsigned-num)
815 (inst shl result :cl)))
817 (define-vop (fast-ash/signed=>signed)
820 (:args (number :scs (signed-reg) :target result)
821 (amount :scs (signed-reg) :target ecx))
822 (:arg-types signed-num signed-num)
823 (:results (result :scs (signed-reg) :from (:argument 0)))
824 (:result-types signed-num)
825 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
831 (inst jmp :ns POSITIVE)
837 (inst sar result :cl)
841 ;; The result-type ensures us that this shift will not overflow.
842 (inst shl result :cl)
846 (define-vop (fast-ash/unsigned=>unsigned)
849 (:args (number :scs (unsigned-reg) :target result)
850 (amount :scs (signed-reg) :target ecx))
851 (:arg-types unsigned-num signed-num)
852 (:results (result :scs (unsigned-reg) :from (:argument 0)))
853 (:result-types unsigned-num)
854 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
860 (inst jmp :ns POSITIVE)
867 (inst shr result :cl)
871 ;; The result-type ensures us that this shift will not overflow.
872 (inst shl result :cl)
878 (defknown %lea (integer integer (member 1 2 4 8 16) (signed-byte 64))
880 (foldable flushable movable))
882 (defoptimizer (%lea derive-type) ((base index scale disp))
883 (when (and (constant-lvar-p scale)
884 (constant-lvar-p disp))
885 (let ((scale (lvar-value scale))
886 (disp (lvar-value disp))
887 (base-type (lvar-type base))
888 (index-type (lvar-type index)))
889 (when (and (numeric-type-p base-type)
890 (numeric-type-p index-type))
891 (let ((base-lo (numeric-type-low base-type))
892 (base-hi (numeric-type-high base-type))
893 (index-lo (numeric-type-low index-type))
894 (index-hi (numeric-type-high index-type)))
895 (make-numeric-type :class 'integer
897 :low (when (and base-lo index-lo)
898 (+ base-lo (* index-lo scale) disp))
899 :high (when (and base-hi index-hi)
900 (+ base-hi (* index-hi scale) disp))))))))
902 (defun %lea (base index scale disp)
903 (+ base (* index scale) disp))
907 (define-vop (%lea/unsigned=>unsigned)
910 (:args (base :scs (unsigned-reg))
911 (index :scs (unsigned-reg)))
913 (:arg-types unsigned-num unsigned-num
914 (:constant (member 1 2 4 8))
915 (:constant (signed-byte 64)))
916 (:results (r :scs (unsigned-reg)))
917 (:result-types unsigned-num)
919 (inst lea r (make-ea :qword :base base :index index
920 :scale scale :disp disp))))
922 (define-vop (%lea/signed=>signed)
925 (:args (base :scs (signed-reg))
926 (index :scs (signed-reg)))
928 (:arg-types signed-num signed-num
929 (:constant (member 1 2 4 8))
930 (:constant (signed-byte 64)))
931 (:results (r :scs (signed-reg)))
932 (:result-types signed-num)
934 (inst lea r (make-ea :qword :base base :index index
935 :scale scale :disp disp))))
937 (define-vop (%lea/fixnum=>fixnum)
940 (:args (base :scs (any-reg))
941 (index :scs (any-reg)))
943 (:arg-types tagged-num tagged-num
944 (:constant (member 1 2 4 8))
945 (:constant (signed-byte 64)))
946 (:results (r :scs (any-reg)))
947 (:result-types tagged-num)
949 (inst lea r (make-ea :qword :base base :index index
950 :scale scale :disp disp))))
952 ;;; FIXME: before making knowledge of this too public, it needs to be
953 ;;; fixed so that it's actually _faster_ than the non-CMOV version; at
954 ;;; least on my Celeron-XXX laptop, this version is marginally slower
955 ;;; than the above version with branches. -- CSR, 2003-09-04
956 (define-vop (fast-cmov-ash/unsigned=>unsigned)
959 (:args (number :scs (unsigned-reg) :target result)
960 (amount :scs (signed-reg) :target ecx))
961 (:arg-types unsigned-num signed-num)
962 (:results (result :scs (unsigned-reg) :from (:argument 0)))
963 (:result-types unsigned-num)
964 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
965 (:temporary (:sc any-reg :from (:eval 0) :to (:eval 1)) zero)
967 (:guard (member :cmov *backend-subfeatures*))
972 (inst jmp :ns POSITIVE)
975 (inst shr result :cl)
977 (inst cmov :nbe result zero)
981 ;; The result-type ensures us that this shift will not overflow.
982 (inst shl result :cl)
986 (define-vop (signed-byte-64-len)
987 (:translate integer-length)
988 (:note "inline (signed-byte 64) integer-length")
990 (:args (arg :scs (signed-reg) :target res))
991 (:arg-types signed-num)
992 (:results (res :scs (unsigned-reg)))
993 (:result-types unsigned-num)
996 (if (sc-is res unsigned-reg)
1010 (define-vop (unsigned-byte-64-len)
1011 (:translate integer-length)
1012 (:note "inline (unsigned-byte 64) integer-length")
1013 (:policy :fast-safe)
1014 (:args (arg :scs (unsigned-reg)))
1015 (:arg-types unsigned-num)
1016 (:results (res :scs (unsigned-reg)))
1017 (:result-types unsigned-num)
1027 (define-vop (unsigned-byte-64-count)
1028 (:translate logcount)
1029 (:note "inline (unsigned-byte 64) logcount")
1030 (:policy :fast-safe)
1031 (:args (arg :scs (unsigned-reg) :target result))
1032 (:arg-types unsigned-num)
1033 (:results (result :scs (unsigned-reg)))
1034 (:result-types positive-fixnum)
1035 (:temporary (:sc unsigned-reg) temp)
1036 (:temporary (:sc unsigned-reg) mask)
1038 ;; See the comments below for how the algorithm works. The tricks
1039 ;; used can be found for example in AMD's software optimization
1040 ;; guide or at "http://www.hackersdelight.org/HDcode/pop.cc" in the
1041 ;; function "pop1", for 32-bit words. The extension to 64 bits is
1043 ;; Calculate 2-bit sums. Note that the value of a two-digit binary
1044 ;; number is the sum of the right digit and twice the left digit.
1045 ;; Thus we can calculate the sum of the two digits by shifting the
1046 ;; left digit to the right position and doing a two-bit subtraction.
1047 ;; This subtraction will never create a borrow and thus can be made
1048 ;; on all 32 2-digit numbers at once.
1052 (inst mov mask #x5555555555555555)
1053 (inst and result mask)
1054 (inst sub temp result)
1055 ;; Calculate 4-bit sums by straightforward shift, mask and add.
1056 ;; Note that we shift the source operand of the MOV and not its
1057 ;; destination so that the SHR and the MOV can execute in the same
1059 (inst mov result temp)
1061 (inst mov mask #x3333333333333333)
1062 (inst and result mask)
1063 (inst and temp mask)
1064 (inst add result temp)
1065 ;; Calculate 8-bit sums. Since each sum is at most 8, which fits
1066 ;; into 4 bits, we can apply the mask after the addition, saving one
1068 (inst mov temp result)
1070 (inst add result temp)
1071 (inst mov mask #x0f0f0f0f0f0f0f0f)
1072 (inst and result mask)
1073 ;; Add all 8 bytes at once by multiplying with #256r11111111.
1074 ;; We need to calculate only the lower 8 bytes of the product.
1075 ;; Of these the most significant byte contains the final result.
1076 ;; Note that there can be no overflow from one byte to the next
1077 ;; as the sum is at most 64 which needs only 7 bits.
1078 (inst mov mask #x0101010101010101)
1079 (inst imul result mask)
1080 (inst shr result 56)))
1082 ;;;; binary conditional VOPs
1084 (define-vop (fast-conditional)
1089 (:policy :fast-safe))
1091 ;;; constant variants are declared for 32 bits not 64 bits, because
1092 ;;; loading a 64 bit constant is silly
1094 (define-vop (fast-conditional/fixnum fast-conditional)
1095 (:args (x :scs (any-reg)
1096 :load-if (not (and (sc-is x control-stack)
1097 (sc-is y any-reg))))
1098 (y :scs (any-reg control-stack)))
1099 (:arg-types tagged-num tagged-num)
1100 (:note "inline fixnum comparison"))
1102 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
1103 (:args (x :scs (any-reg)
1104 :load-if (or (not (typep y '(signed-byte 29)))
1105 (not (sc-is x any-reg control-stack)))))
1106 (:arg-types tagged-num (:constant fixnum))
1109 (define-vop (fast-conditional/signed fast-conditional)
1110 (:args (x :scs (signed-reg)
1111 :load-if (not (and (sc-is x signed-stack)
1112 (sc-is y signed-reg))))
1113 (y :scs (signed-reg signed-stack)))
1114 (:arg-types signed-num signed-num)
1115 (:note "inline (signed-byte 64) comparison"))
1117 (define-vop (fast-conditional-c/signed fast-conditional/signed)
1118 (:args (x :scs (signed-reg)
1119 :load-if (or (not (typep y '(signed-byte 32)))
1120 (not (sc-is x signed-reg signed-stack)))))
1121 (:arg-types signed-num (:constant (signed-byte 64)))
1124 (define-vop (fast-conditional/unsigned fast-conditional)
1125 (:args (x :scs (unsigned-reg)
1126 :load-if (not (and (sc-is x unsigned-stack)
1127 (sc-is y unsigned-reg))))
1128 (y :scs (unsigned-reg unsigned-stack)))
1129 (:arg-types unsigned-num unsigned-num)
1130 (:note "inline (unsigned-byte 64) comparison"))
1132 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
1133 (:args (x :scs (unsigned-reg)
1134 :load-if (or (not (typep y '(unsigned-byte 31)))
1135 (not (sc-is x unsigned-reg unsigned-stack)))))
1136 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
1139 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
1142 (lambda (suffix cost signed)
1143 `(define-vop (;; FIXME: These could be done more
1144 ;; cleanly with SYMBOLICATE.
1145 ,(intern (format nil "~:@(FAST-IF-~A~A~)"
1148 (format nil "~:@(FAST-CONDITIONAL~A~)"
1151 (:conditional ,(if signed cond unsigned))
1156 `(if (typep y '(signed-byte 29))
1158 (register-inline-constant
1159 :qword (fixnumize y))))
1161 `(if (typep y '(signed-byte 32))
1163 (register-inline-constant
1166 `(if (typep y '(unsigned-byte 31))
1168 (register-inline-constant
1171 '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
1172 ; '(/fixnum /signed /unsigned)
1174 '(t t t t nil nil)))))
1176 (define-conditional-vop < :l :b :ge :ae)
1177 (define-conditional-vop > :g :a :le :be))
1179 (define-vop (fast-if-eql/signed fast-conditional/signed)
1184 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
1187 (cond ((and (sc-is x signed-reg) (zerop y))
1188 (inst test x x)) ; smaller instruction
1189 ((typep y '(signed-byte 32))
1192 (inst cmp x (register-inline-constant :qword y))))))
1194 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
1199 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
1202 (cond ((and (sc-is x unsigned-reg) (zerop y))
1203 (inst test x x)) ; smaller instruction
1204 ((typep y '(unsigned-byte 31))
1207 (inst cmp x (register-inline-constant :qword y))))))
1209 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
1212 ;;; These versions specify a fixnum restriction on their first arg. We have
1213 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
1214 ;;; the first arg and a higher cost. The reason for doing this is to prevent
1215 ;;; fixnum specific operations from being used on word integers, spuriously
1216 ;;; consing the argument.
1218 (define-vop (fast-eql/fixnum fast-conditional)
1219 (:args (x :scs (any-reg)
1220 :load-if (not (and (sc-is x control-stack)
1221 (sc-is y any-reg))))
1222 (y :scs (any-reg control-stack)))
1223 (:arg-types tagged-num tagged-num)
1224 (:note "inline fixnum comparison")
1229 (define-vop (generic-eql/fixnum fast-eql/fixnum)
1230 (:args (x :scs (any-reg descriptor-reg)
1231 :load-if (not (and (sc-is x control-stack)
1232 (sc-is y any-reg))))
1233 (y :scs (any-reg control-stack)))
1234 (:arg-types * tagged-num)
1237 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
1238 (:args (x :scs (any-reg)
1239 :load-if (or (not (typep y '(signed-byte 29)))
1240 (not (sc-is x any-reg descriptor-reg control-stack)))))
1241 (:arg-types tagged-num (:constant fixnum))
1245 (cond ((and (sc-is x any-reg descriptor-reg) (zerop y))
1246 (inst test x x)) ; smaller instruction
1247 ((typep y '(signed-byte 29))
1248 (inst cmp x (fixnumize y)))
1250 (inst cmp x (register-inline-constant :qword (fixnumize y)))))))
1252 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
1253 (:args (x :scs (any-reg descriptor-reg)))
1254 (:arg-types * (:constant fixnum))
1257 ;;;; 32-bit logical operations
1259 ;;; Only the lower 6 bits of the shift amount are significant.
1260 (define-vop (shift-towards-someplace)
1261 (:policy :fast-safe)
1262 (:args (num :scs (unsigned-reg) :target r)
1263 (amount :scs (signed-reg) :target ecx))
1264 (:arg-types unsigned-num tagged-num)
1265 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
1266 (:results (r :scs (unsigned-reg) :from (:argument 0)))
1267 (:result-types unsigned-num))
1269 (define-vop (shift-towards-start shift-towards-someplace)
1270 (:translate shift-towards-start)
1271 (:note "SHIFT-TOWARDS-START")
1277 (define-vop (shift-towards-end shift-towards-someplace)
1278 (:translate shift-towards-end)
1279 (:note "SHIFT-TOWARDS-END")
1285 ;;;; Modular functions
1287 (defmacro define-mod-binop ((name prototype) function)
1288 `(define-vop (,name ,prototype)
1289 (:args (x :target r :scs (unsigned-reg signed-reg)
1290 :load-if (not (and (or (sc-is x unsigned-stack)
1291 (sc-is x signed-stack))
1292 (or (sc-is y unsigned-reg)
1293 (sc-is y signed-reg))
1294 (or (sc-is r unsigned-stack)
1295 (sc-is r signed-stack))
1297 (y :scs (unsigned-reg signed-reg unsigned-stack signed-stack)))
1298 (:arg-types untagged-num untagged-num)
1299 (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1300 :load-if (not (and (or (sc-is x unsigned-stack)
1301 (sc-is x signed-stack))
1302 (or (sc-is y unsigned-reg)
1303 (sc-is y unsigned-reg))
1304 (or (sc-is r unsigned-stack)
1305 (sc-is r unsigned-stack))
1307 (:result-types unsigned-num)
1308 (:translate ,function)))
1309 (defmacro define-mod-binop-c ((name prototype) function)
1310 `(define-vop (,name ,prototype)
1311 (:args (x :target r :scs (unsigned-reg signed-reg)
1312 :load-if (not (and (or (sc-is x unsigned-stack)
1313 (sc-is x signed-stack))
1314 (or (sc-is r unsigned-stack)
1315 (sc-is r signed-stack))
1317 (typep y '(signed-byte 32))))))
1319 (:arg-types untagged-num (:constant (or (unsigned-byte 64) (signed-byte 64))))
1320 (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
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 unsigned-stack))
1326 (:result-types unsigned-num)
1327 (:translate ,function)))
1329 (macrolet ((def (name -c-p)
1330 (let ((fun64 (intern (format nil "~S-MOD64" name)))
1331 (vopu (intern (format nil "FAST-~S/UNSIGNED=>UNSIGNED" name)))
1332 (vopcu (intern (format nil "FAST-~S-C/UNSIGNED=>UNSIGNED" name)))
1333 (vopf (intern (format nil "FAST-~S/FIXNUM=>FIXNUM" name)))
1334 (vopcf (intern (format nil "FAST-~S-C/FIXNUM=>FIXNUM" name)))
1335 (vop64u (intern (format nil "FAST-~S-MOD64/WORD=>UNSIGNED" name)))
1336 (vop64f (intern (format nil "FAST-~S-MOD64/FIXNUM=>FIXNUM" name)))
1337 (vop64cu (intern (format nil "FAST-~S-MOD64-C/WORD=>UNSIGNED" name)))
1338 (vop64cf (intern (format nil "FAST-~S-MOD64-C/FIXNUM=>FIXNUM" name)))
1339 (sfun61 (intern (format nil "~S-SMOD61" name)))
1340 (svop61f (intern (format nil "FAST-~S-SMOD61/FIXNUM=>FIXNUM" name)))
1341 (svop61cf (intern (format nil "FAST-~S-SMOD61-C/FIXNUM=>FIXNUM" name))))
1343 (define-modular-fun ,fun64 (x y) ,name :untagged nil 64)
1344 (define-modular-fun ,sfun61 (x y) ,name :tagged t 61)
1345 (define-mod-binop (,vop64u ,vopu) ,fun64)
1346 (define-vop (,vop64f ,vopf) (:translate ,fun64))
1347 (define-vop (,svop61f ,vopf) (:translate ,sfun61))
1349 `((define-mod-binop-c (,vop64cu ,vopcu) ,fun64)
1350 (define-vop (,svop61cf ,vopcf) (:translate ,sfun61))))))))
1355 (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
1356 fast-ash-c/unsigned=>unsigned)
1357 (:translate ash-left-mod64))
1358 (define-vop (fast-ash-left-mod64/unsigned=>unsigned
1359 fast-ash-left/unsigned=>unsigned))
1360 (deftransform ash-left-mod64 ((integer count)
1361 ((unsigned-byte 64) (unsigned-byte 6)))
1362 (when (sb!c::constant-lvar-p count)
1363 (sb!c::give-up-ir1-transform))
1364 '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
1366 (define-vop (fast-ash-left-smod61-c/fixnum=>fixnum
1367 fast-ash-c/fixnum=>fixnum)
1368 (:translate ash-left-smod61))
1369 (define-vop (fast-ash-left-smod61/fixnum=>fixnum
1370 fast-ash-left/fixnum=>fixnum))
1371 (deftransform ash-left-smod61 ((integer count)
1372 ((signed-byte 61) (unsigned-byte 6)))
1373 (when (sb!c::constant-lvar-p count)
1374 (sb!c::give-up-ir1-transform))
1375 '(%primitive fast-ash-left-smod61/fixnum=>fixnum integer count))
1379 (defknown sb!vm::%lea-mod64 (integer integer (member 1 2 4 8) (signed-byte 64))
1381 (foldable flushable movable))
1382 (defknown sb!vm::%lea-smod61 (integer integer (member 1 2 4 8) (signed-byte 64))
1384 (foldable flushable movable))
1386 (define-modular-fun-optimizer %lea ((base index scale disp) :untagged nil :width width)
1387 (when (and (<= width 64)
1388 (constant-lvar-p scale)
1389 (constant-lvar-p disp))
1390 (cut-to-width base :untagged width nil)
1391 (cut-to-width index :untagged width nil)
1392 'sb!vm::%lea-mod64))
1393 (define-modular-fun-optimizer %lea ((base index scale disp) :tagged t :width width)
1394 (when (and (<= width 61)
1395 (constant-lvar-p scale)
1396 (constant-lvar-p disp))
1397 (cut-to-width base :tagged width t)
1398 (cut-to-width index :tagged width t)
1399 'sb!vm::%lea-smod61))
1403 (defun sb!vm::%lea-mod64 (base index scale disp)
1404 (ldb (byte 64 0) (%lea base index scale disp)))
1405 (defun sb!vm::%lea-smod61 (base index scale disp)
1406 (mask-signed-field 61 (%lea base index scale disp))))
1409 (defun sb!vm::%lea-mod64 (base index scale disp)
1410 (let ((base (logand base #xffffffffffffffff))
1411 (index (logand index #xffffffffffffffff)))
1412 ;; can't use modular version of %LEA, as we only have VOPs for
1413 ;; constant SCALE and DISP.
1414 (ldb (byte 64 0) (+ base (* index scale) disp))))
1415 (defun sb!vm::%lea-smod61 (base index scale disp)
1416 (let ((base (mask-signed-field 61 base))
1417 (index (mask-signed-field 61 index)))
1418 ;; can't use modular version of %LEA, as we only have VOPs for
1419 ;; constant SCALE and DISP.
1420 (mask-signed-field 61 (+ base (* index scale) disp)))))
1422 (in-package "SB!VM")
1424 (define-vop (%lea-mod64/unsigned=>unsigned
1425 %lea/unsigned=>unsigned)
1426 (:translate %lea-mod64))
1427 (define-vop (%lea-smod61/fixnum=>fixnum
1428 %lea/fixnum=>fixnum)
1429 (:translate %lea-smod61))
1431 ;;; logical operations
1432 (define-modular-fun lognot-mod64 (x) lognot :untagged nil 64)
1433 (define-vop (lognot-mod64/unsigned=>unsigned)
1434 (:translate lognot-mod64)
1435 (:args (x :scs (unsigned-reg unsigned-stack) :target r
1436 :load-if (not (and (sc-is x unsigned-stack)
1437 (sc-is r unsigned-stack)
1439 (:arg-types unsigned-num)
1440 (:results (r :scs (unsigned-reg)
1441 :load-if (not (and (sc-is x unsigned-stack)
1442 (sc-is r unsigned-stack)
1444 (:result-types unsigned-num)
1445 (:policy :fast-safe)
1450 (define-source-transform logeqv (&rest args)
1451 (if (oddp (length args))
1453 `(lognot (logxor ,@args))))
1454 (define-source-transform logandc1 (x y)
1455 `(logand (lognot ,x) ,y))
1456 (define-source-transform logandc2 (x y)
1457 `(logand ,x (lognot ,y)))
1458 (define-source-transform logorc1 (x y)
1459 `(logior (lognot ,x) ,y))
1460 (define-source-transform logorc2 (x y)
1461 `(logior ,x (lognot ,y)))
1462 (define-source-transform lognor (x y)
1463 `(lognot (logior ,x ,y)))
1464 (define-source-transform lognand (x y)
1465 `(lognot (logand ,x ,y)))
1469 (define-vop (bignum-length get-header-data)
1470 (:translate sb!bignum:%bignum-length)
1471 (:policy :fast-safe))
1473 (define-vop (bignum-set-length set-header-data)
1474 (:translate sb!bignum:%bignum-set-length)
1475 (:policy :fast-safe))
1477 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
1478 (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
1479 (define-full-reffer+offset bignum--ref-with-offset * bignum-digits-offset
1480 other-pointer-lowtag (unsigned-reg) unsigned-num
1481 sb!bignum:%bignum-ref-with-offset)
1482 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
1483 (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
1485 (define-vop (digit-0-or-plus)
1486 (:translate sb!bignum:%digit-0-or-plusp)
1487 (:policy :fast-safe)
1488 (:args (digit :scs (unsigned-reg)))
1489 (:arg-types unsigned-num)
1492 (inst or digit digit)))
1495 ;;; For add and sub with carry the sc of carry argument is any-reg so
1496 ;;; that it may be passed as a fixnum or word and thus may be 0, 1, or
1497 ;;; 8. This is easy to deal with and may save a fixnum-word
1499 (define-vop (add-w/carry)
1500 (:translate sb!bignum:%add-with-carry)
1501 (:policy :fast-safe)
1502 (:args (a :scs (unsigned-reg) :target result)
1503 (b :scs (unsigned-reg unsigned-stack) :to :eval)
1504 (c :scs (any-reg) :target temp))
1505 (:arg-types unsigned-num unsigned-num positive-fixnum)
1506 (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
1507 (:results (result :scs (unsigned-reg) :from (:argument 0))
1508 (carry :scs (unsigned-reg)))
1509 (:result-types unsigned-num positive-fixnum)
1513 (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
1516 (inst adc carry carry)))
1518 ;;; Note: the borrow is 1 for no borrow and 0 for a borrow, the opposite
1519 ;;; of the x86-64 convention.
1520 (define-vop (sub-w/borrow)
1521 (:translate sb!bignum:%subtract-with-borrow)
1522 (:policy :fast-safe)
1523 (:args (a :scs (unsigned-reg) :to :eval :target result)
1524 (b :scs (unsigned-reg unsigned-stack) :to :result)
1525 (c :scs (any-reg control-stack)))
1526 (:arg-types unsigned-num unsigned-num positive-fixnum)
1527 (:results (result :scs (unsigned-reg) :from :eval)
1528 (borrow :scs (unsigned-reg)))
1529 (:result-types unsigned-num positive-fixnum)
1531 (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
1535 (inst sbb borrow 0)))
1538 (define-vop (bignum-mult-and-add-3-arg)
1539 (:translate sb!bignum:%multiply-and-add)
1540 (:policy :fast-safe)
1541 (:args (x :scs (unsigned-reg) :target eax)
1542 (y :scs (unsigned-reg unsigned-stack))
1543 (carry-in :scs (unsigned-reg unsigned-stack)))
1544 (:arg-types unsigned-num unsigned-num unsigned-num)
1545 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1546 :to (:result 1) :target lo) eax)
1547 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1548 :to (:result 0) :target hi) edx)
1549 (:results (hi :scs (unsigned-reg))
1550 (lo :scs (unsigned-reg)))
1551 (:result-types unsigned-num unsigned-num)
1555 (inst add eax carry-in)
1560 (define-vop (bignum-mult-and-add-4-arg)
1561 (:translate sb!bignum:%multiply-and-add)
1562 (:policy :fast-safe)
1563 (:args (x :scs (unsigned-reg) :target eax)
1564 (y :scs (unsigned-reg unsigned-stack))
1565 (prev :scs (unsigned-reg unsigned-stack))
1566 (carry-in :scs (unsigned-reg unsigned-stack)))
1567 (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1568 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1569 :to (:result 1) :target lo) eax)
1570 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1571 :to (:result 0) :target hi) edx)
1572 (:results (hi :scs (unsigned-reg))
1573 (lo :scs (unsigned-reg)))
1574 (:result-types unsigned-num unsigned-num)
1580 (inst add eax carry-in)
1586 (define-vop (bignum-mult)
1587 (:translate sb!bignum:%multiply)
1588 (:policy :fast-safe)
1589 (:args (x :scs (unsigned-reg) :target eax)
1590 (y :scs (unsigned-reg unsigned-stack)))
1591 (:arg-types unsigned-num unsigned-num)
1592 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1593 :to (:result 1) :target lo) eax)
1594 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1595 :to (:result 0) :target hi) edx)
1596 (:results (hi :scs (unsigned-reg))
1597 (lo :scs (unsigned-reg)))
1598 (:result-types unsigned-num unsigned-num)
1605 (define-vop (bignum-lognot lognot-mod64/unsigned=>unsigned)
1606 (:translate sb!bignum:%lognot))
1608 (define-vop (fixnum-to-digit)
1609 (:translate sb!bignum:%fixnum-to-digit)
1610 (:policy :fast-safe)
1611 (:args (fixnum :scs (any-reg control-stack) :target digit))
1612 (:arg-types tagged-num)
1613 (:results (digit :scs (unsigned-reg)
1614 :load-if (not (and (sc-is fixnum control-stack)
1615 (sc-is digit unsigned-stack)
1616 (location= fixnum digit)))))
1617 (:result-types unsigned-num)
1620 (inst sar digit 3)))
1622 (define-vop (bignum-floor)
1623 (:translate sb!bignum:%floor)
1624 (:policy :fast-safe)
1625 (:args (div-high :scs (unsigned-reg) :target edx)
1626 (div-low :scs (unsigned-reg) :target eax)
1627 (divisor :scs (unsigned-reg unsigned-stack)))
1628 (:arg-types unsigned-num unsigned-num unsigned-num)
1629 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
1630 :to (:result 0) :target quo) eax)
1631 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
1632 :to (:result 1) :target rem) edx)
1633 (:results (quo :scs (unsigned-reg))
1634 (rem :scs (unsigned-reg)))
1635 (:result-types unsigned-num unsigned-num)
1639 (inst div eax divisor)
1643 (define-vop (signify-digit)
1644 (:translate sb!bignum:%fixnum-digit-with-correct-sign)
1645 (:policy :fast-safe)
1646 (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
1647 (:arg-types unsigned-num)
1648 (:results (res :scs (any-reg signed-reg)
1649 :load-if (not (and (sc-is digit unsigned-stack)
1650 (sc-is res control-stack signed-stack)
1651 (location= digit res)))))
1652 (:result-types signed-num)
1655 (when (sc-is res any-reg control-stack)
1658 (define-vop (digit-ashr)
1659 (:translate sb!bignum:%ashr)
1660 (:policy :fast-safe)
1661 (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
1662 (count :scs (unsigned-reg) :target ecx))
1663 (:arg-types unsigned-num positive-fixnum)
1664 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
1665 (:results (result :scs (unsigned-reg) :from (:argument 0)
1666 :load-if (not (and (sc-is result unsigned-stack)
1667 (location= digit result)))))
1668 (:result-types unsigned-num)
1672 (inst sar result :cl)))
1674 (define-vop (digit-ashr/c)
1675 (:translate sb!bignum:%ashr)
1676 (:policy :fast-safe)
1677 (:args (digit :scs (unsigned-reg unsigned-stack) :target result))
1678 (:arg-types unsigned-num (:constant (integer 0 63)))
1680 (:results (result :scs (unsigned-reg) :from (:argument 0)
1681 :load-if (not (and (sc-is result unsigned-stack)
1682 (location= digit result)))))
1683 (:result-types unsigned-num)
1686 (inst sar result count)))
1688 (define-vop (digit-lshr digit-ashr)
1689 (:translate sb!bignum:%digit-logical-shift-right)
1693 (inst shr result :cl)))
1695 (define-vop (digit-ashl digit-ashr)
1696 (:translate sb!bignum:%ashl)
1700 (inst shl result :cl)))
1702 ;;;; static functions
1704 (define-static-fun two-arg-/ (x y) :translate /)
1706 (define-static-fun two-arg-gcd (x y) :translate gcd)
1707 (define-static-fun two-arg-lcm (x y) :translate lcm)
1709 (define-static-fun two-arg-and (x y) :translate logand)
1710 (define-static-fun two-arg-ior (x y) :translate logior)
1711 (define-static-fun two-arg-xor (x y) :translate logxor)
1716 (defun *-transformer (y)
1718 ((= y (ash 1 (integer-length y)))
1719 ;; there's a generic transform for y = 2^k
1720 (give-up-ir1-transform))
1721 ((member y '(3 5 9))
1722 ;; we can do these multiplications directly using LEA
1723 `(%lea x x ,(1- y) 0))
1725 ;; A normal 64-bit multiplication takes 4 cycles on Athlon 64/Opteron.
1726 ;; Optimizing multiplications (other than the above cases) to
1727 ;; shifts/adds/leas gives a maximum improvement of 1 cycle, but requires
1728 ;; quite a lot of hairy code.
1729 (give-up-ir1-transform))))
1731 (deftransform * ((x y)
1732 ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1734 "recode as leas, shifts and adds"
1735 (let ((y (lvar-value y)))
1737 (deftransform sb!vm::*-mod64
1738 ((x y) ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1740 "recode as leas, shifts and adds"
1741 (let ((y (lvar-value y)))
1744 (deftransform * ((x y)
1745 ((signed-byte 61) (constant-arg (unsigned-byte 64)))
1747 "recode as leas, shifts and adds"
1748 (let ((y (lvar-value y)))
1750 (deftransform sb!vm::*-smod61
1751 ((x y) ((signed-byte 61) (constant-arg (unsigned-byte 64)))
1753 "recode as leas, shifts and adds"
1754 (let ((y (lvar-value y)))