1 ;;;; the VM definition of arithmetic VOPs for the x86-64
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
16 (define-vop (fast-safe-arith-op)
21 (define-vop (fixnum-unop fast-safe-arith-op)
22 (:args (x :scs (any-reg) :target res))
23 (:results (res :scs (any-reg)))
24 (:note "inline fixnum arithmetic")
25 (:arg-types tagged-num)
26 (:result-types tagged-num))
28 (define-vop (signed-unop fast-safe-arith-op)
29 (:args (x :scs (signed-reg) :target res))
30 (:results (res :scs (signed-reg)))
31 (:note "inline (signed-byte 64) arithmetic")
32 (:arg-types signed-num)
33 (:result-types signed-num))
35 (define-vop (fast-negate/fixnum fixnum-unop)
41 (define-vop (fast-negate/signed signed-unop)
47 (define-vop (fast-lognot/fixnum fixnum-unop)
51 (inst xor res (fixnumize -1))))
53 (define-vop (fast-lognot/signed signed-unop)
59 ;;;; binary fixnum operations
61 ;;; Assume that any constant operand is the second arg...
63 (define-vop (fast-fixnum-binop fast-safe-arith-op)
64 (:args (x :target r :scs (any-reg)
65 :load-if (not (and (sc-is x control-stack)
67 (sc-is r control-stack)
69 (y :scs (any-reg control-stack)))
70 (:arg-types tagged-num tagged-num)
71 (:results (r :scs (any-reg) :from (:argument 0)
72 :load-if (not (and (sc-is x control-stack)
74 (sc-is r control-stack)
76 (:result-types tagged-num)
77 (:note "inline fixnum arithmetic"))
79 (define-vop (fast-unsigned-binop fast-safe-arith-op)
80 (:args (x :target r :scs (unsigned-reg)
81 :load-if (not (and (sc-is x unsigned-stack)
82 (sc-is y unsigned-reg)
83 (sc-is r unsigned-stack)
85 (y :scs (unsigned-reg unsigned-stack)))
86 (:arg-types unsigned-num unsigned-num)
87 (:results (r :scs (unsigned-reg) :from (:argument 0)
88 :load-if (not (and (sc-is x unsigned-stack)
89 (sc-is y unsigned-reg)
90 (sc-is r unsigned-stack)
92 (:result-types unsigned-num)
93 (:note "inline (unsigned-byte 64) arithmetic"))
95 (define-vop (fast-signed-binop fast-safe-arith-op)
96 (:args (x :target r :scs (signed-reg)
97 :load-if (not (and (sc-is x signed-stack)
99 (sc-is r signed-stack)
101 (y :scs (signed-reg signed-stack)))
102 (:arg-types signed-num signed-num)
103 (:results (r :scs (signed-reg) :from (:argument 0)
104 :load-if (not (and (sc-is x signed-stack)
106 (sc-is r signed-stack)
108 (:result-types signed-num)
109 (:note "inline (signed-byte 64) arithmetic"))
111 (define-vop (fast-fixnum-binop-c fast-safe-arith-op)
112 (:args (x :target r :scs (any-reg)
113 :load-if (or (not (typep y '(signed-byte 29)))
114 (not (sc-is x any-reg control-stack)))))
116 (:arg-types tagged-num (:constant fixnum))
117 (:results (r :scs (any-reg)
118 :load-if (or (not (location= x r))
119 (not (typep y '(signed-byte 29))))))
120 (:result-types tagged-num)
121 (:note "inline fixnum arithmetic"))
123 (define-vop (fast-unsigned-binop-c fast-safe-arith-op)
124 (:args (x :target r :scs (unsigned-reg)
125 :load-if (or (not (typep y '(unsigned-byte 31)))
126 (not (sc-is x unsigned-reg unsigned-stack)))))
128 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
129 (:results (r :scs (unsigned-reg)
130 :load-if (or (not (location= x r))
131 (not (typep y '(unsigned-byte 31))))))
132 (:result-types unsigned-num)
133 (:note "inline (unsigned-byte 64) arithmetic"))
135 (define-vop (fast-signed-binop-c fast-safe-arith-op)
136 (:args (x :target r :scs (signed-reg)
137 :load-if (or (not (typep y '(signed-byte 32)))
138 (not (sc-is x signed-reg signed-stack)))))
140 (:arg-types signed-num (:constant (signed-byte 64)))
141 (:results (r :scs (signed-reg)
142 :load-if (or (not (location= x r))
143 (not (typep y '(signed-byte 32))))))
144 (:result-types signed-num)
145 (:note "inline (signed-byte 64) arithmetic"))
147 (macrolet ((define-binop (translate untagged-penalty op)
149 (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
151 (:translate ,translate)
155 (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
157 (:translate ,translate)
160 (inst ,op r (if (typep y '(signed-byte 29))
162 (register-inline-constant :qword (fixnumize y))))))
163 (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
165 (:translate ,translate)
166 (:generator ,(1+ untagged-penalty)
169 (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
171 (:translate ,translate)
172 (:generator ,untagged-penalty
174 (inst ,op r (if (typep y '(signed-byte 32))
176 (register-inline-constant :qword y)))))
177 (define-vop (,(symbolicate "FAST-"
179 "/UNSIGNED=>UNSIGNED")
181 (:translate ,translate)
182 (:generator ,(1+ untagged-penalty)
185 (define-vop (,(symbolicate 'fast-
187 '-c/unsigned=>unsigned)
188 fast-unsigned-binop-c)
189 (:translate ,translate)
190 (:generator ,untagged-penalty
192 (inst ,op r (if (typep y '(unsigned-byte 31))
194 (register-inline-constant :qword y))))))))
196 ;;(define-binop + 4 add)
197 (define-binop - 4 sub)
198 (define-binop logand 2 and)
199 (define-binop logior 2 or)
200 (define-binop logxor 2 xor))
202 ;;; Special handling of add on the x86; can use lea to avoid a
203 ;;; register load, otherwise it uses add.
204 (define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op)
206 (:args (x :scs (any-reg) :target r
207 :load-if (not (and (sc-is x control-stack)
209 (sc-is r control-stack)
211 (y :scs (any-reg control-stack)))
212 (:arg-types tagged-num tagged-num)
213 (:results (r :scs (any-reg) :from (:argument 0)
214 :load-if (not (and (sc-is x control-stack)
216 (sc-is r control-stack)
218 (:result-types tagged-num)
219 (:note "inline fixnum arithmetic")
221 (cond ((and (sc-is x any-reg) (sc-is y any-reg) (sc-is r any-reg)
222 (not (location= x r)))
223 (inst lea r (make-ea :qword :base x :index y :scale 1)))
228 (define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op)
230 (:args (x :target r :scs (any-reg)
231 :load-if (or (not (typep y '(signed-byte 29)))
232 (not (sc-is x any-reg control-stack)))))
234 (:arg-types tagged-num (:constant fixnum))
235 (:results (r :scs (any-reg)
236 :load-if (or (not (location= x r))
237 (not (typep y '(signed-byte 29))))))
238 (:result-types tagged-num)
239 (:note "inline fixnum arithmetic")
241 (cond ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r))
242 (typep y '(signed-byte 29)))
243 (inst lea r (make-ea :qword :base x :disp (fixnumize y))))
244 ((typep y '(signed-byte 29))
246 (inst add r (fixnumize y)))
249 (inst add r (register-inline-constant :qword (fixnumize y)))))))
251 (define-vop (fast-+/signed=>signed fast-safe-arith-op)
253 (:args (x :scs (signed-reg) :target r
254 :load-if (not (and (sc-is x signed-stack)
256 (sc-is r signed-stack)
258 (y :scs (signed-reg signed-stack)))
259 (:arg-types signed-num signed-num)
260 (:results (r :scs (signed-reg) :from (:argument 0)
261 :load-if (not (and (sc-is x signed-stack)
264 (:result-types signed-num)
265 (:note "inline (signed-byte 64) arithmetic")
267 (cond ((and (sc-is x signed-reg) (sc-is y signed-reg) (sc-is r signed-reg)
268 (not (location= x r)))
269 (inst lea r (make-ea :qword :base x :index y :scale 1)))
275 ;;;; Special logand cases: (logand signed unsigned) => unsigned
277 (define-vop (fast-logand/signed-unsigned=>unsigned
278 fast-logand/unsigned=>unsigned)
279 (:args (x :target r :scs (signed-reg)
280 :load-if (not (and (sc-is x signed-stack)
281 (sc-is y unsigned-reg)
282 (sc-is r unsigned-stack)
284 (y :scs (unsigned-reg unsigned-stack)))
285 (:arg-types signed-num unsigned-num))
287 (define-vop (fast-logand-c/signed-unsigned=>unsigned
288 fast-logand-c/unsigned=>unsigned)
289 (:args (x :target r :scs (signed-reg)
290 :load-if (or (not (typep y '(unsigned-byte 31)))
291 (not (sc-is r signed-reg signed-stack)))))
292 (:arg-types signed-num (:constant (unsigned-byte 64))))
294 (define-vop (fast-logand/unsigned-signed=>unsigned
295 fast-logand/unsigned=>unsigned)
296 (:args (x :target r :scs (unsigned-reg)
297 :load-if (not (and (sc-is x unsigned-stack)
299 (sc-is r unsigned-stack)
301 (y :scs (signed-reg signed-stack)))
302 (:arg-types unsigned-num signed-num))
305 (define-vop (fast-+-c/signed=>signed fast-safe-arith-op)
307 (:args (x :target r :scs (signed-reg)
308 :load-if (or (not (typep y '(signed-byte 32)))
309 (not (sc-is r signed-reg signed-stack)))))
311 (:arg-types signed-num (:constant (signed-byte 64)))
312 (:results (r :scs (signed-reg)
313 :load-if (or (not (location= x r))
314 (not (typep y '(signed-byte 32))))))
315 (:result-types signed-num)
316 (:note "inline (signed-byte 64) arithmetic")
318 (cond ((and (sc-is x signed-reg) (sc-is r signed-reg)
319 (not (location= x r))
320 (typep y '(signed-byte 32)))
321 (inst lea r (make-ea :qword :base x :disp y)))
326 ((typep y '(signed-byte 32))
329 (inst add r (register-inline-constant :qword y))))))))
331 (define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op)
333 (:args (x :scs (unsigned-reg) :target r
334 :load-if (not (and (sc-is x unsigned-stack)
335 (sc-is y unsigned-reg)
336 (sc-is r unsigned-stack)
338 (y :scs (unsigned-reg unsigned-stack)))
339 (:arg-types unsigned-num unsigned-num)
340 (:results (r :scs (unsigned-reg) :from (:argument 0)
341 :load-if (not (and (sc-is x unsigned-stack)
342 (sc-is y unsigned-reg)
343 (sc-is r unsigned-stack)
345 (:result-types unsigned-num)
346 (:note "inline (unsigned-byte 64) arithmetic")
348 (cond ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg)
349 (sc-is r unsigned-reg) (not (location= x r)))
350 (inst lea r (make-ea :qword :base x :index y :scale 1)))
355 (define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op)
357 (:args (x :target r :scs (unsigned-reg)
358 :load-if (or (not (typep y '(unsigned-byte 31)))
359 (not (sc-is x unsigned-reg unsigned-stack)))))
361 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
362 (:results (r :scs (unsigned-reg)
363 :load-if (or (not (location= x r))
364 (not (typep y '(unsigned-byte 31))))))
365 (:result-types unsigned-num)
366 (:note "inline (unsigned-byte 64) arithmetic")
368 (cond ((and (sc-is x unsigned-reg) (sc-is r unsigned-reg)
369 (not (location= x r))
370 (typep y '(unsigned-byte 31)))
371 (inst lea r (make-ea :qword :base x :disp y)))
376 ((typep y '(unsigned-byte 31))
379 (inst add r (register-inline-constant :qword y))))))))
381 ;;;; multiplication and division
383 (define-vop (fast-*/fixnum=>fixnum fast-safe-arith-op)
385 ;; We need different loading characteristics.
386 (:args (x :scs (any-reg) :target r)
387 (y :scs (any-reg control-stack)))
388 (:arg-types tagged-num tagged-num)
389 (:results (r :scs (any-reg) :from (:argument 0)))
390 (:result-types tagged-num)
391 (:note "inline fixnum arithmetic")
394 (inst sar r n-fixnum-tag-bits)
397 (define-vop (fast-*-c/fixnum=>fixnum fast-safe-arith-op)
399 ;; We need different loading characteristics.
400 (:args (x :scs (any-reg)
401 :load-if (or (not (typep y '(signed-byte 32)))
402 (not (sc-is x any-reg control-stack)))))
404 (:arg-types tagged-num (:constant fixnum))
405 (:results (r :scs (any-reg)))
406 (:result-types tagged-num)
407 (:note "inline fixnum arithmetic")
409 (cond ((typep y '(signed-byte 32))
413 (inst imul r (register-inline-constant :qword y))))))
415 (define-vop (fast-*/signed=>signed fast-safe-arith-op)
417 ;; We need different loading characteristics.
418 (:args (x :scs (signed-reg) :target r)
419 (y :scs (signed-reg signed-stack)))
420 (:arg-types signed-num signed-num)
421 (:results (r :scs (signed-reg) :from (:argument 0)))
422 (:result-types signed-num)
423 (:note "inline (signed-byte 64) arithmetic")
428 (define-vop (fast-*-c/signed=>signed fast-safe-arith-op)
430 ;; We need different loading characteristics.
431 (:args (x :scs (signed-reg)
432 :load-if (or (not (typep y '(signed-byte 32)))
433 (not (sc-is x signed-reg signed-stack)))))
435 (:arg-types signed-num (:constant (signed-byte 64)))
436 (:results (r :scs (signed-reg)))
437 (:result-types signed-num)
438 (:note "inline (signed-byte 64) arithmetic")
440 (cond ((typep y '(signed-byte 32))
444 (inst imul r (register-inline-constant :qword y))))))
446 (define-vop (fast-*/unsigned=>unsigned fast-safe-arith-op)
448 (:args (x :scs (unsigned-reg) :target eax)
449 (y :scs (unsigned-reg unsigned-stack)))
450 (:arg-types unsigned-num unsigned-num)
451 (:temporary (:sc unsigned-reg :offset eax-offset :target r
452 :from (:argument 0) :to :result) eax)
453 (:temporary (:sc unsigned-reg :offset edx-offset
454 :from :eval :to :result) edx)
456 (:results (r :scs (unsigned-reg)))
457 (:result-types unsigned-num)
458 (:note "inline (unsigned-byte 64) arithmetic")
460 (:save-p :compute-only)
466 (define-vop (fast-*-c/unsigned=>unsigned fast-safe-arith-op)
468 (:args (x :scs (unsigned-reg) :target eax))
470 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
471 (:temporary (:sc unsigned-reg :offset eax-offset :target r
472 :from (:argument 0) :to :result) eax)
473 (:temporary (:sc unsigned-reg :offset edx-offset
474 :from :eval :to :result) edx)
476 (:results (r :scs (unsigned-reg)))
477 (:result-types unsigned-num)
478 (:note "inline (unsigned-byte 64) arithmetic")
480 (:save-p :compute-only)
483 (inst mul eax (register-inline-constant :qword y))
487 (define-vop (fast-truncate/fixnum=>fixnum fast-safe-arith-op)
488 (:translate truncate)
489 (:args (x :scs (any-reg) :target eax)
490 (y :scs (any-reg control-stack)))
491 (:arg-types tagged-num tagged-num)
492 (:temporary (:sc signed-reg :offset eax-offset :target quo
493 :from (:argument 0) :to (:result 0)) eax)
494 (:temporary (:sc unsigned-reg :offset edx-offset :target rem
495 :from (:argument 0) :to (:result 1)) edx)
496 (:results (quo :scs (any-reg))
497 (rem :scs (any-reg)))
498 (:result-types tagged-num tagged-num)
499 (:note "inline fixnum arithmetic")
501 (:save-p :compute-only)
503 (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
504 (if (sc-is y any-reg)
505 (inst test y y) ; smaller instruction
511 (if (location= quo eax)
512 (inst shl eax n-fixnum-tag-bits)
513 (if (= n-fixnum-tag-bits 1)
514 (inst lea quo (make-ea :qword :base eax :index eax))
515 (inst lea quo (make-ea :qword :index eax
516 :scale (ash 1 n-fixnum-tag-bits)))))
519 (define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
520 (:translate truncate)
521 (:args (x :scs (any-reg) :target eax))
523 (:arg-types tagged-num (:constant fixnum))
524 (:temporary (:sc signed-reg :offset eax-offset :target quo
525 :from :argument :to (:result 0)) eax)
526 (:temporary (:sc any-reg :offset edx-offset :target rem
527 :from :eval :to (:result 1)) edx)
528 (:temporary (:sc any-reg :from :eval :to :result) y-arg)
529 (:results (quo :scs (any-reg))
530 (rem :scs (any-reg)))
531 (:result-types tagged-num tagged-num)
532 (:note "inline fixnum arithmetic")
534 (:save-p :compute-only)
538 (if (typep y '(signed-byte 29))
539 (inst mov y-arg (fixnumize y))
540 (setf y-arg (register-inline-constant :qword (fixnumize y))))
541 (inst idiv eax y-arg)
542 (if (location= quo eax)
543 (inst shl eax n-fixnum-tag-bits)
544 (if (= n-fixnum-tag-bits 1)
545 (inst lea quo (make-ea :qword :base eax :index eax))
546 (inst lea quo (make-ea :qword :index eax
547 :scale (ash 1 n-fixnum-tag-bits)))))
550 (define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
551 (:translate truncate)
552 (:args (x :scs (unsigned-reg) :target eax)
553 (y :scs (unsigned-reg signed-stack)))
554 (:arg-types unsigned-num unsigned-num)
555 (:temporary (:sc unsigned-reg :offset eax-offset :target quo
556 :from (:argument 0) :to (:result 0)) eax)
557 (:temporary (:sc unsigned-reg :offset edx-offset :target rem
558 :from (:argument 0) :to (:result 1)) edx)
559 (:results (quo :scs (unsigned-reg))
560 (rem :scs (unsigned-reg)))
561 (:result-types unsigned-num unsigned-num)
562 (:note "inline (unsigned-byte 64) arithmetic")
564 (:save-p :compute-only)
566 (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
567 (if (sc-is y unsigned-reg)
568 (inst test y y) ; smaller instruction
577 (define-vop (fast-truncate-c/unsigned=>unsigned fast-safe-arith-op)
578 (:translate truncate)
579 (:args (x :scs (unsigned-reg) :target eax))
581 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
582 (:temporary (:sc unsigned-reg :offset eax-offset :target quo
583 :from :argument :to (:result 0)) eax)
584 (:temporary (:sc unsigned-reg :offset edx-offset :target rem
585 :from :eval :to (:result 1)) edx)
586 (:temporary (:sc unsigned-reg :from :eval :to :result) y-arg)
587 (:results (quo :scs (unsigned-reg))
588 (rem :scs (unsigned-reg)))
589 (:result-types unsigned-num unsigned-num)
590 (:note "inline (unsigned-byte 64) arithmetic")
592 (:save-p :compute-only)
596 (if (typep y '(unsigned-byte 31))
598 (setf y-arg (register-inline-constant :qword y)))
603 (define-vop (fast-truncate/signed=>signed fast-safe-arith-op)
604 (:translate truncate)
605 (:args (x :scs (signed-reg) :target eax)
606 (y :scs (signed-reg signed-stack)))
607 (:arg-types signed-num signed-num)
608 (:temporary (:sc signed-reg :offset eax-offset :target quo
609 :from (:argument 0) :to (:result 0)) eax)
610 (:temporary (:sc signed-reg :offset edx-offset :target rem
611 :from (:argument 0) :to (:result 1)) edx)
612 (:results (quo :scs (signed-reg))
613 (rem :scs (signed-reg)))
614 (:result-types signed-num signed-num)
615 (:note "inline (signed-byte 64) arithmetic")
617 (:save-p :compute-only)
619 (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
620 (if (sc-is y signed-reg)
621 (inst test y y) ; smaller instruction
630 (define-vop (fast-truncate-c/signed=>signed fast-safe-arith-op)
631 (:translate truncate)
632 (:args (x :scs (signed-reg) :target eax))
634 (:arg-types signed-num (:constant (signed-byte 64)))
635 (:temporary (:sc signed-reg :offset eax-offset :target quo
636 :from :argument :to (:result 0)) eax)
637 (:temporary (:sc signed-reg :offset edx-offset :target rem
638 :from :eval :to (:result 1)) edx)
639 (:temporary (:sc signed-reg :from :eval :to :result) y-arg)
640 (:results (quo :scs (signed-reg))
641 (rem :scs (signed-reg)))
642 (:result-types signed-num signed-num)
643 (:note "inline (signed-byte 64) arithmetic")
645 (:save-p :compute-only)
649 (if (typep y '(signed-byte 32))
651 (setf y-arg (register-inline-constant :qword y)))
652 (inst idiv eax y-arg)
659 (define-vop (fast-ash-c/fixnum=>fixnum)
662 (:args (number :scs (any-reg) :target result
663 :load-if (not (and (sc-is number any-reg control-stack)
664 (sc-is result any-reg control-stack)
665 (location= number result)))))
667 (:arg-types tagged-num (:constant integer))
668 (:results (result :scs (any-reg)
669 :load-if (not (and (sc-is number control-stack)
670 (sc-is result control-stack)
671 (location= number result)))))
672 (:result-types tagged-num)
675 (:variant-vars modularp)
677 (cond ((and (= amount 1) (not (location= number result)))
678 (inst lea result (make-ea :qword :base number :index number)))
679 ((and (= amount 2) (not (location= number result)))
680 (inst lea result (make-ea :qword :index number :scale 4)))
681 ((and (= amount 3) (not (location= number result)))
682 (inst lea result (make-ea :qword :index number :scale 8)))
685 (cond ((< -64 amount 64)
686 ;; this code is used both in ASH and ASH-MODFX, so
689 (inst shl result amount)
691 (inst sar result (- amount))
692 (inst and result (lognot fixnum-tag-mask)))))
693 ;; shifting left (zero fill)
696 (aver (not "Impossible: fixnum ASH should not be called with
697 constant shift greater than word length")))
698 (if (sc-is result any-reg)
700 (inst mov result 0)))
701 ;; shifting right (sign fill)
702 (t (inst sar result 63)
703 (inst and result (lognot fixnum-tag-mask))))))))
705 (define-vop (fast-ash-left/fixnum=>fixnum)
707 (:args (number :scs (any-reg) :target result
708 :load-if (not (and (sc-is number control-stack)
709 (sc-is result control-stack)
710 (location= number result))))
711 (amount :scs (unsigned-reg) :target ecx))
712 (:arg-types tagged-num positive-fixnum)
713 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
714 (:results (result :scs (any-reg) :from (:argument 0)
715 :load-if (not (and (sc-is number control-stack)
716 (sc-is result control-stack)
717 (location= number result)))))
718 (:result-types tagged-num)
724 ;; The result-type ensures us that this shift will not overflow.
725 (inst shl result :cl)))
727 (define-vop (fast-ash-c/signed=>signed)
730 (:args (number :scs (signed-reg) :target result
731 :load-if (not (and (sc-is number signed-stack)
732 (sc-is result signed-stack)
733 (location= number result)))))
735 (:arg-types signed-num (:constant integer))
736 (:results (result :scs (signed-reg)
737 :load-if (not (and (sc-is number signed-stack)
738 (sc-is result signed-stack)
739 (location= number result)))))
740 (:result-types signed-num)
743 (cond ((and (= amount 1) (not (location= number result)))
744 (inst lea result (make-ea :qword :base number :index number)))
745 ((and (= amount 2) (not (location= number result)))
746 (inst lea result (make-ea :qword :index number :scale 4)))
747 ((and (= amount 3) (not (location= number result)))
748 (inst lea result (make-ea :qword :index number :scale 8)))
751 (cond ((plusp amount) (inst shl result amount))
752 (t (inst sar result (min 63 (- amount)))))))))
754 (define-vop (fast-ash-c/unsigned=>unsigned)
757 (:args (number :scs (unsigned-reg) :target result
758 :load-if (not (and (sc-is number unsigned-stack)
759 (sc-is result unsigned-stack)
760 (location= number result)))))
762 (:arg-types unsigned-num (:constant integer))
763 (:results (result :scs (unsigned-reg)
764 :load-if (not (and (sc-is number unsigned-stack)
765 (sc-is result unsigned-stack)
766 (location= number result)))))
767 (:result-types unsigned-num)
770 (cond ((and (= amount 1) (not (location= number result)))
771 (inst lea result (make-ea :qword :base number :index number)))
772 ((and (= amount 2) (not (location= number result)))
773 (inst lea result (make-ea :qword :index number :scale 4)))
774 ((and (= amount 3) (not (location= number result)))
775 (inst lea result (make-ea :qword :index number :scale 8)))
778 (cond ((< -64 amount 64) ;; XXXX
779 ;; this code is used both in ASH and ASH-MOD32, so
782 (inst shl result amount)
783 (inst shr result (- amount))))
784 (t (if (sc-is result unsigned-reg)
786 (inst mov result 0))))))))
788 (define-vop (fast-ash-left/signed=>signed)
790 (:args (number :scs (signed-reg) :target result
791 :load-if (not (and (sc-is number signed-stack)
792 (sc-is result signed-stack)
793 (location= number result))))
794 (amount :scs (unsigned-reg) :target ecx))
795 (:arg-types signed-num positive-fixnum)
796 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
797 (:results (result :scs (signed-reg) :from (:argument 0)
798 :load-if (not (and (sc-is number signed-stack)
799 (sc-is result signed-stack)
800 (location= number result)))))
801 (:result-types signed-num)
807 (inst shl result :cl)))
809 (define-vop (fast-ash-left/unsigned=>unsigned)
811 (:args (number :scs (unsigned-reg) :target result
812 :load-if (not (and (sc-is number unsigned-stack)
813 (sc-is result unsigned-stack)
814 (location= number result))))
815 (amount :scs (unsigned-reg) :target ecx))
816 (:arg-types unsigned-num positive-fixnum)
817 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
818 (:results (result :scs (unsigned-reg) :from (:argument 0)
819 :load-if (not (and (sc-is number unsigned-stack)
820 (sc-is result unsigned-stack)
821 (location= number result)))))
822 (:result-types unsigned-num)
828 (inst shl result :cl)))
830 (define-vop (fast-ash/signed=>signed)
833 (:args (number :scs (signed-reg) :target result)
834 (amount :scs (signed-reg) :target ecx))
835 (:arg-types signed-num signed-num)
836 (:results (result :scs (signed-reg) :from (:argument 0)))
837 (:result-types signed-num)
838 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
844 (inst jmp :ns POSITIVE)
850 (inst sar result :cl)
854 ;; The result-type ensures us that this shift will not overflow.
855 (inst shl result :cl)
859 (define-vop (fast-ash/unsigned=>unsigned)
862 (:args (number :scs (unsigned-reg) :target result)
863 (amount :scs (signed-reg) :target ecx))
864 (:arg-types unsigned-num signed-num)
865 (:results (result :scs (unsigned-reg) :from (:argument 0)))
866 (:result-types unsigned-num)
867 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
873 (inst jmp :ns POSITIVE)
880 (inst shr result :cl)
884 ;; The result-type ensures us that this shift will not overflow.
885 (inst shl result :cl)
891 (defknown %lea (integer integer (member 1 2 4 8 16) (signed-byte 64))
893 (foldable flushable movable))
895 (defoptimizer (%lea derive-type) ((base index scale disp))
896 (when (and (constant-lvar-p scale)
897 (constant-lvar-p disp))
898 (let ((scale (lvar-value scale))
899 (disp (lvar-value disp))
900 (base-type (lvar-type base))
901 (index-type (lvar-type index)))
902 (when (and (numeric-type-p base-type)
903 (numeric-type-p index-type))
904 (let ((base-lo (numeric-type-low base-type))
905 (base-hi (numeric-type-high base-type))
906 (index-lo (numeric-type-low index-type))
907 (index-hi (numeric-type-high index-type)))
908 (make-numeric-type :class 'integer
910 :low (when (and base-lo index-lo)
911 (+ base-lo (* index-lo scale) disp))
912 :high (when (and base-hi index-hi)
913 (+ base-hi (* index-hi scale) disp))))))))
915 (defun %lea (base index scale disp)
916 (+ base (* index scale) disp))
920 (define-vop (%lea/unsigned=>unsigned)
923 (:args (base :scs (unsigned-reg))
924 (index :scs (unsigned-reg)))
926 (:arg-types unsigned-num unsigned-num
927 (:constant (member 1 2 4 8))
928 (:constant (signed-byte 64)))
929 (:results (r :scs (unsigned-reg)))
930 (:result-types unsigned-num)
932 (inst lea r (make-ea :qword :base base :index index
933 :scale scale :disp disp))))
935 (define-vop (%lea/signed=>signed)
938 (:args (base :scs (signed-reg))
939 (index :scs (signed-reg)))
941 (:arg-types signed-num signed-num
942 (:constant (member 1 2 4 8))
943 (:constant (signed-byte 64)))
944 (:results (r :scs (signed-reg)))
945 (:result-types signed-num)
947 (inst lea r (make-ea :qword :base base :index index
948 :scale scale :disp disp))))
950 (define-vop (%lea/fixnum=>fixnum)
953 (:args (base :scs (any-reg))
954 (index :scs (any-reg)))
956 (:arg-types tagged-num tagged-num
957 (:constant (member 1 2 4 8))
958 (:constant (signed-byte 64)))
959 (:results (r :scs (any-reg)))
960 (:result-types tagged-num)
962 (inst lea r (make-ea :qword :base base :index index
963 :scale scale :disp disp))))
965 ;;; FIXME: before making knowledge of this too public, it needs to be
966 ;;; fixed so that it's actually _faster_ than the non-CMOV version; at
967 ;;; least on my Celeron-XXX laptop, this version is marginally slower
968 ;;; than the above version with branches. -- CSR, 2003-09-04
969 (define-vop (fast-cmov-ash/unsigned=>unsigned)
972 (:args (number :scs (unsigned-reg) :target result)
973 (amount :scs (signed-reg) :target ecx))
974 (:arg-types unsigned-num signed-num)
975 (:results (result :scs (unsigned-reg) :from (:argument 0)))
976 (:result-types unsigned-num)
977 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
978 (:temporary (:sc any-reg :from (:eval 0) :to (:eval 1)) zero)
980 (:guard (member :cmov *backend-subfeatures*))
985 (inst jmp :ns POSITIVE)
988 (inst shr result :cl)
990 (inst cmov :nbe result zero)
994 ;; The result-type ensures us that this shift will not overflow.
995 (inst shl result :cl)
999 (define-vop (signed-byte-64-len)
1000 (:translate integer-length)
1001 (:note "inline (signed-byte 64) integer-length")
1002 (:policy :fast-safe)
1003 (:args (arg :scs (signed-reg) :target res))
1004 (:arg-types signed-num)
1005 (:results (res :scs (unsigned-reg)))
1006 (:result-types unsigned-num)
1009 (if (sc-is res unsigned-reg)
1023 (define-vop (unsigned-byte-64-len)
1024 (:translate integer-length)
1025 (:note "inline (unsigned-byte 64) integer-length")
1026 (:policy :fast-safe)
1027 (:args (arg :scs (unsigned-reg)))
1028 (:arg-types unsigned-num)
1029 (:results (res :scs (unsigned-reg)))
1030 (:result-types unsigned-num)
1040 (define-vop (unsigned-byte-64-count)
1041 (:translate logcount)
1042 (:note "inline (unsigned-byte 64) logcount")
1043 (:policy :fast-safe)
1044 (:args (arg :scs (unsigned-reg) :target result))
1045 (:arg-types unsigned-num)
1046 (:results (result :scs (unsigned-reg)))
1047 (:result-types positive-fixnum)
1048 (:temporary (:sc unsigned-reg) temp)
1049 (:temporary (:sc unsigned-reg) mask)
1051 ;; See the comments below for how the algorithm works. The tricks
1052 ;; used can be found for example in AMD's software optimization
1053 ;; guide or at "http://www.hackersdelight.org/HDcode/pop.cc" in the
1054 ;; function "pop1", for 32-bit words. The extension to 64 bits is
1056 ;; Calculate 2-bit sums. Note that the value of a two-digit binary
1057 ;; number is the sum of the right digit and twice the left digit.
1058 ;; Thus we can calculate the sum of the two digits by shifting the
1059 ;; left digit to the right position and doing a two-bit subtraction.
1060 ;; This subtraction will never create a borrow and thus can be made
1061 ;; on all 32 2-digit numbers at once.
1065 (inst mov mask #x5555555555555555)
1066 (inst and result mask)
1067 (inst sub temp result)
1068 ;; Calculate 4-bit sums by straightforward shift, mask and add.
1069 ;; Note that we shift the source operand of the MOV and not its
1070 ;; destination so that the SHR and the MOV can execute in the same
1072 (inst mov result temp)
1074 (inst mov mask #x3333333333333333)
1075 (inst and result mask)
1076 (inst and temp mask)
1077 (inst add result temp)
1078 ;; Calculate 8-bit sums. Since each sum is at most 8, which fits
1079 ;; into 4 bits, we can apply the mask after the addition, saving one
1081 (inst mov temp result)
1083 (inst add result temp)
1084 (inst mov mask #x0f0f0f0f0f0f0f0f)
1085 (inst and result mask)
1086 ;; Add all 8 bytes at once by multiplying with #256r11111111.
1087 ;; We need to calculate only the lower 8 bytes of the product.
1088 ;; Of these the most significant byte contains the final result.
1089 ;; Note that there can be no overflow from one byte to the next
1090 ;; as the sum is at most 64 which needs only 7 bits.
1091 (inst mov mask #x0101010101010101)
1092 (inst imul result mask)
1093 (inst shr result 56)))
1095 ;;;; binary conditional VOPs
1097 (define-vop (fast-conditional)
1102 (:policy :fast-safe))
1104 ;;; constant variants are declared for 32 bits not 64 bits, because
1105 ;;; loading a 64 bit constant is silly
1107 (define-vop (fast-conditional/fixnum fast-conditional)
1108 (:args (x :scs (any-reg)
1109 :load-if (not (and (sc-is x control-stack)
1110 (sc-is y any-reg))))
1111 (y :scs (any-reg control-stack)))
1112 (:arg-types tagged-num tagged-num)
1113 (:note "inline fixnum comparison"))
1115 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
1116 (:args (x :scs (any-reg)
1117 :load-if (or (not (typep y '(signed-byte 29)))
1118 (not (sc-is x any-reg control-stack)))))
1119 (:arg-types tagged-num (:constant fixnum))
1122 (define-vop (fast-conditional/signed fast-conditional)
1123 (:args (x :scs (signed-reg)
1124 :load-if (not (and (sc-is x signed-stack)
1125 (sc-is y signed-reg))))
1126 (y :scs (signed-reg signed-stack)))
1127 (:arg-types signed-num signed-num)
1128 (:note "inline (signed-byte 64) comparison"))
1130 (define-vop (fast-conditional-c/signed fast-conditional/signed)
1131 (:args (x :scs (signed-reg)
1132 :load-if (or (not (typep y '(signed-byte 32)))
1133 (not (sc-is x signed-reg signed-stack)))))
1134 (:arg-types signed-num (:constant (signed-byte 64)))
1137 (define-vop (fast-conditional/unsigned fast-conditional)
1138 (:args (x :scs (unsigned-reg)
1139 :load-if (not (and (sc-is x unsigned-stack)
1140 (sc-is y unsigned-reg))))
1141 (y :scs (unsigned-reg unsigned-stack)))
1142 (:arg-types unsigned-num unsigned-num)
1143 (:note "inline (unsigned-byte 64) comparison"))
1145 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
1146 (:args (x :scs (unsigned-reg)
1147 :load-if (or (not (typep y '(unsigned-byte 31)))
1148 (not (sc-is x unsigned-reg unsigned-stack)))))
1149 (:arg-types unsigned-num (:constant (unsigned-byte 64)))
1152 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
1155 (lambda (suffix cost signed)
1156 `(define-vop (;; FIXME: These could be done more
1157 ;; cleanly with SYMBOLICATE.
1158 ,(intern (format nil "~:@(FAST-IF-~A~A~)"
1161 (format nil "~:@(FAST-CONDITIONAL~A~)"
1164 (:conditional ,(if signed cond unsigned))
1169 `(if (typep y '(signed-byte 29))
1171 (register-inline-constant
1172 :qword (fixnumize y))))
1174 `(if (typep y '(signed-byte 32))
1176 (register-inline-constant
1179 `(if (typep y '(unsigned-byte 31))
1181 (register-inline-constant
1184 '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
1185 ; '(/fixnum /signed /unsigned)
1187 '(t t t t nil nil)))))
1189 (define-conditional-vop < :l :b :ge :ae)
1190 (define-conditional-vop > :g :a :le :be))
1192 (define-vop (fast-if-eql/signed fast-conditional/signed)
1197 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
1200 (cond ((and (sc-is x signed-reg) (zerop y))
1201 (inst test x x)) ; smaller instruction
1202 ((typep y '(signed-byte 32))
1205 (inst cmp x (register-inline-constant :qword y))))))
1207 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
1212 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
1215 (cond ((and (sc-is x unsigned-reg) (zerop y))
1216 (inst test x x)) ; smaller instruction
1217 ((typep y '(unsigned-byte 31))
1220 (inst cmp x (register-inline-constant :qword y))))))
1222 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
1225 ;;; These versions specify a fixnum restriction on their first arg. We have
1226 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
1227 ;;; the first arg and a higher cost. The reason for doing this is to prevent
1228 ;;; fixnum specific operations from being used on word integers, spuriously
1229 ;;; consing the argument.
1231 (define-vop (fast-eql/fixnum fast-conditional)
1232 (:args (x :scs (any-reg)
1233 :load-if (not (and (sc-is x control-stack)
1234 (sc-is y any-reg))))
1235 (y :scs (any-reg control-stack)))
1236 (:arg-types tagged-num tagged-num)
1237 (:note "inline fixnum comparison")
1242 (define-vop (generic-eql/fixnum fast-eql/fixnum)
1243 (:args (x :scs (any-reg descriptor-reg)
1244 :load-if (not (and (sc-is x control-stack)
1245 (sc-is y any-reg))))
1246 (y :scs (any-reg control-stack)))
1247 (:arg-types * tagged-num)
1250 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
1251 (:args (x :scs (any-reg)
1252 :load-if (or (not (typep y '(signed-byte 29)))
1253 (not (sc-is x any-reg descriptor-reg control-stack)))))
1254 (:arg-types tagged-num (:constant fixnum))
1258 (cond ((and (sc-is x any-reg descriptor-reg) (zerop y))
1259 (inst test x x)) ; smaller instruction
1260 ((typep y '(signed-byte 29))
1261 (inst cmp x (fixnumize y)))
1263 (inst cmp x (register-inline-constant :qword (fixnumize y)))))))
1265 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
1266 (:args (x :scs (any-reg descriptor-reg)))
1267 (:arg-types * (:constant fixnum))
1270 ;;;; 32-bit logical operations
1272 ;;; Only the lower 6 bits of the shift amount are significant.
1273 (define-vop (shift-towards-someplace)
1274 (:policy :fast-safe)
1275 (:args (num :scs (unsigned-reg) :target r)
1276 (amount :scs (signed-reg) :target ecx))
1277 (:arg-types unsigned-num tagged-num)
1278 (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
1279 (:results (r :scs (unsigned-reg) :from (:argument 0)))
1280 (:result-types unsigned-num))
1282 (define-vop (shift-towards-start shift-towards-someplace)
1283 (:translate shift-towards-start)
1284 (:note "SHIFT-TOWARDS-START")
1290 (define-vop (shift-towards-end shift-towards-someplace)
1291 (:translate shift-towards-end)
1292 (:note "SHIFT-TOWARDS-END")
1298 ;;;; Modular functions
1300 (defmacro define-mod-binop ((name prototype) function)
1301 `(define-vop (,name ,prototype)
1302 (:args (x :target r :scs (unsigned-reg signed-reg)
1303 :load-if (not (and (or (sc-is x unsigned-stack)
1304 (sc-is x signed-stack))
1305 (or (sc-is y unsigned-reg)
1306 (sc-is y signed-reg))
1307 (or (sc-is r unsigned-stack)
1308 (sc-is r signed-stack))
1310 (y :scs (unsigned-reg signed-reg unsigned-stack signed-stack)))
1311 (:arg-types untagged-num untagged-num)
1312 (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1313 :load-if (not (and (or (sc-is x unsigned-stack)
1314 (sc-is x signed-stack))
1315 (or (sc-is y unsigned-reg)
1316 (sc-is y unsigned-reg))
1317 (or (sc-is r unsigned-stack)
1318 (sc-is r unsigned-stack))
1320 (:result-types unsigned-num)
1321 (:translate ,function)))
1322 (defmacro define-mod-binop-c ((name prototype) function)
1323 `(define-vop (,name ,prototype)
1324 (:args (x :target r :scs (unsigned-reg signed-reg)
1325 :load-if (not (and (or (sc-is x unsigned-stack)
1326 (sc-is x signed-stack))
1327 (or (sc-is r unsigned-stack)
1328 (sc-is r signed-stack))
1330 (typep y '(signed-byte 32))))))
1332 (:arg-types untagged-num (:constant (or (unsigned-byte 64) (signed-byte 64))))
1333 (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1334 :load-if (not (and (or (sc-is x unsigned-stack)
1335 (sc-is x signed-stack))
1336 (or (sc-is r unsigned-stack)
1337 (sc-is r unsigned-stack))
1339 (:result-types unsigned-num)
1340 (:translate ,function)))
1342 (macrolet ((def (name -c-p)
1343 (let ((fun64 (intern (format nil "~S-MOD64" name)))
1344 (vopu (intern (format nil "FAST-~S/UNSIGNED=>UNSIGNED" name)))
1345 (vopcu (intern (format nil "FAST-~S-C/UNSIGNED=>UNSIGNED" name)))
1346 (vopf (intern (format nil "FAST-~S/FIXNUM=>FIXNUM" name)))
1347 (vopcf (intern (format nil "FAST-~S-C/FIXNUM=>FIXNUM" name)))
1348 (vop64u (intern (format nil "FAST-~S-MOD64/WORD=>UNSIGNED" name)))
1349 (vop64f (intern (format nil "FAST-~S-MOD64/FIXNUM=>FIXNUM" name)))
1350 (vop64cu (intern (format nil "FAST-~S-MOD64-C/WORD=>UNSIGNED" name)))
1351 (vop64cf (intern (format nil "FAST-~S-MOD64-C/FIXNUM=>FIXNUM" name)))
1352 (funfx (intern (format nil "~S-MODFX" name)))
1353 (vopfxf (intern (format nil "FAST-~S-MODFX/FIXNUM=>FIXNUM" name)))
1354 (vopfxcf (intern (format nil "FAST-~S-MODFX-C/FIXNUM=>FIXNUM" name))))
1356 (define-modular-fun ,fun64 (x y) ,name :untagged nil 64)
1357 (define-modular-fun ,funfx (x y) ,name :tagged t
1358 #.(- n-word-bits n-fixnum-tag-bits))
1359 (define-mod-binop (,vop64u ,vopu) ,fun64)
1360 (define-vop (,vop64f ,vopf) (:translate ,fun64))
1361 (define-vop (,vopfxf ,vopf) (:translate ,funfx))
1363 `((define-mod-binop-c (,vop64cu ,vopcu) ,fun64)
1364 (define-vop (,vopfxcf ,vopcf) (:translate ,funfx))))))))
1369 (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
1370 fast-ash-c/unsigned=>unsigned)
1371 (:translate ash-left-mod64))
1372 (define-vop (fast-ash-left-mod64/unsigned=>unsigned
1373 fast-ash-left/unsigned=>unsigned))
1374 (deftransform ash-left-mod64 ((integer count)
1375 ((unsigned-byte 64) (unsigned-byte 6)))
1376 (when (sb!c::constant-lvar-p count)
1377 (sb!c::give-up-ir1-transform))
1378 '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
1380 (define-vop (fast-ash-left-modfx-c/fixnum=>fixnum
1381 fast-ash-c/fixnum=>fixnum)
1383 (:translate ash-left-modfx))
1384 (define-vop (fast-ash-left-modfx/fixnum=>fixnum
1385 fast-ash-left/fixnum=>fixnum))
1386 (deftransform ash-left-modfx ((integer count)
1387 (fixnum (unsigned-byte 6)))
1388 (when (sb!c::constant-lvar-p count)
1389 (sb!c::give-up-ir1-transform))
1390 '(%primitive fast-ash-left-modfx/fixnum=>fixnum integer count))
1394 (defknown sb!vm::%lea-mod64 (integer integer (member 1 2 4 8) (signed-byte 64))
1396 (foldable flushable movable))
1397 (defknown sb!vm::%lea-modfx (integer integer (member 1 2 4 8) (signed-byte 64))
1399 (foldable flushable movable))
1401 (define-modular-fun-optimizer %lea ((base index scale disp) :untagged nil :width width)
1402 (when (and (<= width 64)
1403 (constant-lvar-p scale)
1404 (constant-lvar-p disp))
1405 (cut-to-width base :untagged width nil)
1406 (cut-to-width index :untagged width nil)
1407 'sb!vm::%lea-mod64))
1408 (define-modular-fun-optimizer %lea ((base index scale disp) :tagged t :width width)
1409 (when (and (<= width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
1410 (constant-lvar-p scale)
1411 (constant-lvar-p disp))
1412 (cut-to-width base :tagged width t)
1413 (cut-to-width index :tagged width t)
1414 'sb!vm::%lea-modfx))
1418 (defun sb!vm::%lea-mod64 (base index scale disp)
1419 (ldb (byte 64 0) (%lea base index scale disp)))
1420 (defun sb!vm::%lea-modfx (base index scale disp)
1421 (mask-signed-field (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)
1422 (%lea base index scale disp))))
1425 (defun sb!vm::%lea-mod64 (base index scale disp)
1426 (let ((base (logand base #xffffffffffffffff))
1427 (index (logand index #xffffffffffffffff)))
1428 ;; can't use modular version of %LEA, as we only have VOPs for
1429 ;; constant SCALE and DISP.
1430 (ldb (byte 64 0) (+ base (* index scale) disp))))
1431 (defun sb!vm::%lea-modfx (base index scale disp)
1432 (let* ((fixnum-width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
1433 (base (mask-signed-field fixnum-width base))
1434 (index (mask-signed-field fixnum-width index)))
1435 ;; can't use modular version of %LEA, as we only have VOPs for
1436 ;; constant SCALE and DISP.
1437 (mask-signed-field fixnum-width (+ base (* index scale) disp)))))
1439 (in-package "SB!VM")
1441 (define-vop (%lea-mod64/unsigned=>unsigned
1442 %lea/unsigned=>unsigned)
1443 (:translate %lea-mod64))
1444 (define-vop (%lea-modfx/fixnum=>fixnum
1445 %lea/fixnum=>fixnum)
1446 (:translate %lea-modfx))
1448 ;;; logical operations
1449 (define-modular-fun lognot-mod64 (x) lognot :untagged nil 64)
1450 (define-vop (lognot-mod64/unsigned=>unsigned)
1451 (:translate lognot-mod64)
1452 (:args (x :scs (unsigned-reg unsigned-stack) :target r
1453 :load-if (not (and (sc-is x unsigned-stack)
1454 (sc-is r unsigned-stack)
1456 (:arg-types unsigned-num)
1457 (:results (r :scs (unsigned-reg)
1458 :load-if (not (and (sc-is x unsigned-stack)
1459 (sc-is r unsigned-stack)
1461 (:result-types unsigned-num)
1462 (:policy :fast-safe)
1467 (define-source-transform logeqv (&rest args)
1468 (if (oddp (length args))
1470 `(lognot (logxor ,@args))))
1471 (define-source-transform logandc1 (x y)
1472 `(logand (lognot ,x) ,y))
1473 (define-source-transform logandc2 (x y)
1474 `(logand ,x (lognot ,y)))
1475 (define-source-transform logorc1 (x y)
1476 `(logior (lognot ,x) ,y))
1477 (define-source-transform logorc2 (x y)
1478 `(logior ,x (lognot ,y)))
1479 (define-source-transform lognor (x y)
1480 `(lognot (logior ,x ,y)))
1481 (define-source-transform lognand (x y)
1482 `(lognot (logand ,x ,y)))
1486 (define-vop (bignum-length get-header-data)
1487 (:translate sb!bignum:%bignum-length)
1488 (:policy :fast-safe))
1490 (define-vop (bignum-set-length set-header-data)
1491 (:translate sb!bignum:%bignum-set-length)
1492 (:policy :fast-safe))
1494 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
1495 (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
1496 (define-full-reffer+offset bignum--ref-with-offset * bignum-digits-offset
1497 other-pointer-lowtag (unsigned-reg) unsigned-num
1498 sb!bignum:%bignum-ref-with-offset)
1499 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
1500 (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
1502 (define-vop (digit-0-or-plus)
1503 (:translate sb!bignum:%digit-0-or-plusp)
1504 (:policy :fast-safe)
1505 (:args (digit :scs (unsigned-reg)))
1506 (:arg-types unsigned-num)
1509 (inst test digit digit)))
1512 ;;; For add and sub with carry the sc of carry argument is any-reg so
1513 ;;; that it may be passed as a fixnum or word and thus may be 0, 1, or
1514 ;;; 8. This is easy to deal with and may save a fixnum-word
1516 (define-vop (add-w/carry)
1517 (:translate sb!bignum:%add-with-carry)
1518 (:policy :fast-safe)
1519 (:args (a :scs (unsigned-reg) :target result)
1520 (b :scs (unsigned-reg unsigned-stack) :to :eval)
1521 (c :scs (any-reg) :target temp))
1522 (:arg-types unsigned-num unsigned-num positive-fixnum)
1523 (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
1524 (:results (result :scs (unsigned-reg) :from (:argument 0))
1525 (carry :scs (unsigned-reg)))
1526 (:result-types unsigned-num positive-fixnum)
1530 (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
1533 (inst adc carry carry)))
1535 ;;; Note: the borrow is 1 for no borrow and 0 for a borrow, the opposite
1536 ;;; of the x86-64 convention.
1537 (define-vop (sub-w/borrow)
1538 (:translate sb!bignum:%subtract-with-borrow)
1539 (:policy :fast-safe)
1540 (:args (a :scs (unsigned-reg) :to :eval :target result)
1541 (b :scs (unsigned-reg unsigned-stack) :to :result)
1542 (c :scs (any-reg control-stack)))
1543 (:arg-types unsigned-num unsigned-num positive-fixnum)
1544 (:results (result :scs (unsigned-reg) :from :eval)
1545 (borrow :scs (unsigned-reg)))
1546 (:result-types unsigned-num positive-fixnum)
1548 (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
1552 (inst sbb borrow 0)))
1555 (define-vop (bignum-mult-and-add-3-arg)
1556 (:translate sb!bignum:%multiply-and-add)
1557 (:policy :fast-safe)
1558 (:args (x :scs (unsigned-reg) :target eax)
1559 (y :scs (unsigned-reg unsigned-stack))
1560 (carry-in :scs (unsigned-reg unsigned-stack)))
1561 (:arg-types unsigned-num unsigned-num unsigned-num)
1562 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1563 :to (:result 1) :target lo) eax)
1564 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1565 :to (:result 0) :target hi) edx)
1566 (:results (hi :scs (unsigned-reg))
1567 (lo :scs (unsigned-reg)))
1568 (:result-types unsigned-num unsigned-num)
1572 (inst add eax carry-in)
1577 (define-vop (bignum-mult-and-add-4-arg)
1578 (:translate sb!bignum:%multiply-and-add)
1579 (:policy :fast-safe)
1580 (:args (x :scs (unsigned-reg) :target eax)
1581 (y :scs (unsigned-reg unsigned-stack))
1582 (prev :scs (unsigned-reg unsigned-stack))
1583 (carry-in :scs (unsigned-reg unsigned-stack)))
1584 (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1585 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1586 :to (:result 1) :target lo) eax)
1587 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1588 :to (:result 0) :target hi) edx)
1589 (:results (hi :scs (unsigned-reg))
1590 (lo :scs (unsigned-reg)))
1591 (:result-types unsigned-num unsigned-num)
1597 (inst add eax carry-in)
1603 (define-vop (bignum-mult)
1604 (:translate sb!bignum:%multiply)
1605 (:policy :fast-safe)
1606 (:args (x :scs (unsigned-reg) :target eax)
1607 (y :scs (unsigned-reg unsigned-stack)))
1608 (:arg-types unsigned-num unsigned-num)
1609 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1610 :to (:result 1) :target lo) eax)
1611 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1612 :to (:result 0) :target hi) edx)
1613 (:results (hi :scs (unsigned-reg))
1614 (lo :scs (unsigned-reg)))
1615 (:result-types unsigned-num unsigned-num)
1622 #!+multiply-high-vops
1624 (:translate sb!kernel:%multiply-high)
1625 (:policy :fast-safe)
1626 (:args (x :scs (unsigned-reg) :target eax)
1627 (y :scs (unsigned-reg unsigned-stack)))
1628 (:arg-types unsigned-num unsigned-num)
1629 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0))
1631 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1632 :to (:result 0) :target hi) edx)
1633 (:results (hi :scs (unsigned-reg)))
1634 (:result-types unsigned-num)
1640 #!+multiply-high-vops
1641 (define-vop (mulhi/fx)
1642 (:translate sb!kernel:%multiply-high)
1643 (:policy :fast-safe)
1644 (:args (x :scs (any-reg) :target eax)
1645 (y :scs (unsigned-reg unsigned-stack)))
1646 (:arg-types positive-fixnum unsigned-num)
1647 (:temporary (:sc any-reg :offset eax-offset :from (:argument 0)) eax)
1648 (:temporary (:sc any-reg :offset edx-offset :from (:argument 1)
1649 :to (:result 0) :target hi) edx)
1650 (:results (hi :scs (any-reg)))
1651 (:result-types positive-fixnum)
1656 (inst and hi (lognot fixnum-tag-mask))))
1658 (define-vop (bignum-lognot lognot-mod64/unsigned=>unsigned)
1659 (:translate sb!bignum:%lognot))
1661 (define-vop (fixnum-to-digit)
1662 (:translate sb!bignum:%fixnum-to-digit)
1663 (:policy :fast-safe)
1664 (:args (fixnum :scs (any-reg control-stack) :target digit))
1665 (:arg-types tagged-num)
1666 (:results (digit :scs (unsigned-reg)
1667 :load-if (not (and (sc-is fixnum control-stack)
1668 (sc-is digit unsigned-stack)
1669 (location= fixnum digit)))))
1670 (:result-types unsigned-num)
1673 (inst sar digit n-fixnum-tag-bits)))
1675 (define-vop (bignum-floor)
1676 (:translate sb!bignum:%bigfloor)
1677 (:policy :fast-safe)
1678 (:args (div-high :scs (unsigned-reg) :target edx)
1679 (div-low :scs (unsigned-reg) :target eax)
1680 (divisor :scs (unsigned-reg unsigned-stack)))
1681 (:arg-types unsigned-num unsigned-num unsigned-num)
1682 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
1683 :to (:result 0) :target quo) eax)
1684 (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
1685 :to (:result 1) :target rem) edx)
1686 (:results (quo :scs (unsigned-reg))
1687 (rem :scs (unsigned-reg)))
1688 (:result-types unsigned-num unsigned-num)
1692 (inst div eax divisor)
1696 (define-vop (signify-digit)
1697 (:translate sb!bignum:%fixnum-digit-with-correct-sign)
1698 (:policy :fast-safe)
1699 (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
1700 (:arg-types unsigned-num)
1701 (:results (res :scs (any-reg signed-reg)
1702 :load-if (not (and (sc-is digit unsigned-stack)
1703 (sc-is res control-stack signed-stack)
1704 (location= digit res)))))
1705 (:result-types signed-num)
1708 (when (sc-is res any-reg control-stack)
1709 (inst shl res n-fixnum-tag-bits))))
1711 (define-vop (digit-ashr)
1712 (:translate sb!bignum:%ashr)
1713 (:policy :fast-safe)
1714 (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
1715 (count :scs (unsigned-reg) :target ecx))
1716 (:arg-types unsigned-num positive-fixnum)
1717 (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
1718 (:results (result :scs (unsigned-reg) :from (:argument 0)
1719 :load-if (not (and (sc-is result unsigned-stack)
1720 (location= digit result)))))
1721 (:result-types unsigned-num)
1725 (inst sar result :cl)))
1727 (define-vop (digit-ashr/c)
1728 (:translate sb!bignum:%ashr)
1729 (:policy :fast-safe)
1730 (:args (digit :scs (unsigned-reg unsigned-stack) :target result))
1731 (:arg-types unsigned-num (:constant (integer 0 63)))
1733 (:results (result :scs (unsigned-reg) :from (:argument 0)
1734 :load-if (not (and (sc-is result unsigned-stack)
1735 (location= digit result)))))
1736 (:result-types unsigned-num)
1739 (inst sar result count)))
1741 (define-vop (digit-lshr digit-ashr)
1742 (:translate sb!bignum:%digit-logical-shift-right)
1746 (inst shr result :cl)))
1748 (define-vop (digit-ashl digit-ashr)
1749 (:translate sb!bignum:%ashl)
1753 (inst shl result :cl)))
1755 ;;;; static functions
1757 (define-static-fun two-arg-/ (x y) :translate /)
1759 (define-static-fun two-arg-gcd (x y) :translate gcd)
1760 (define-static-fun two-arg-lcm (x y) :translate lcm)
1762 (define-static-fun two-arg-and (x y) :translate logand)
1763 (define-static-fun two-arg-ior (x y) :translate logior)
1764 (define-static-fun two-arg-xor (x y) :translate logxor)
1769 (defun *-transformer (y)
1771 ((= y (ash 1 (integer-length y)))
1772 ;; there's a generic transform for y = 2^k
1773 (give-up-ir1-transform))
1774 ((member y '(3 5 9))
1775 ;; we can do these multiplications directly using LEA
1776 `(%lea x x ,(1- y) 0))
1778 ;; A normal 64-bit multiplication takes 4 cycles on Athlon 64/Opteron.
1779 ;; Optimizing multiplications (other than the above cases) to
1780 ;; shifts/adds/leas gives a maximum improvement of 1 cycle, but requires
1781 ;; quite a lot of hairy code.
1782 (give-up-ir1-transform))))
1784 (deftransform * ((x y)
1785 ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1787 "recode as leas, shifts and adds"
1788 (let ((y (lvar-value y)))
1790 (deftransform sb!vm::*-mod64
1791 ((x y) ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1793 "recode as leas, shifts and adds"
1794 (let ((y (lvar-value y)))
1797 (deftransform * ((x y)
1798 (fixnum (constant-arg (unsigned-byte 64)))
1800 "recode as leas, shifts and adds"
1801 (let ((y (lvar-value y)))
1803 (deftransform sb!vm::*-modfx
1804 ((x y) (fixnum (constant-arg (unsigned-byte 64)))
1806 "recode as leas, shifts and adds"
1807 (let ((y (lvar-value y)))