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 control-stack
)))
114 (:arg-types tagged-num
(:constant
(signed-byte 29)))
115 (:results
(r :scs
(any-reg)
116 :load-if
(not (location= x r
))))
117 (:result-types tagged-num
)
118 (:note
"inline fixnum arithmetic"))
120 ;; 31 not 64 because it's hard work loading 64 bit constants, and since
121 ;; sign-extension of immediates causes problems with 32.
122 (define-vop (fast-unsigned-binop-c fast-safe-arith-op
)
123 (:args
(x :target r
:scs
(unsigned-reg unsigned-stack
)))
125 (:arg-types unsigned-num
(:constant
(unsigned-byte 31)))
126 (:results
(r :scs
(unsigned-reg)
127 :load-if
(not (location= x r
))))
128 (:result-types unsigned-num
)
129 (:note
"inline (unsigned-byte 64) arithmetic"))
131 (define-vop (fast-signed-binop-c fast-safe-arith-op
)
132 (:args
(x :target r
:scs
(signed-reg signed-stack
)))
134 (:arg-types signed-num
(:constant
(signed-byte 32)))
135 (:results
(r :scs
(signed-reg)
136 :load-if
(not (location= x r
))))
137 (:result-types signed-num
)
138 (:note
"inline (signed-byte 64) arithmetic"))
140 (macrolet ((define-binop (translate untagged-penalty op
)
142 (define-vop (,(symbolicate "FAST-" translate
"/FIXNUM=>FIXNUM")
144 (:translate
,translate
)
148 (define-vop (,(symbolicate 'fast- translate
'-c
/fixnum
=>fixnum
)
150 (:translate
,translate
)
153 (inst ,op r
(fixnumize y
))))
154 (define-vop (,(symbolicate "FAST-" translate
"/SIGNED=>SIGNED")
156 (:translate
,translate
)
157 (:generator
,(1+ untagged-penalty
)
160 (define-vop (,(symbolicate 'fast- translate
'-c
/signed
=>signed
)
162 (:translate
,translate
)
163 (:generator
,untagged-penalty
166 (define-vop (,(symbolicate "FAST-"
168 "/UNSIGNED=>UNSIGNED")
170 (:translate
,translate
)
171 (:generator
,(1+ untagged-penalty
)
174 (define-vop (,(symbolicate 'fast-
176 '-c
/unsigned
=>unsigned
)
177 fast-unsigned-binop-c
)
178 (:translate
,translate
)
179 (:generator
,untagged-penalty
183 ;;(define-binop + 4 add)
184 (define-binop -
4 sub
)
185 (define-binop logand
2 and
)
186 (define-binop logior
2 or
)
187 (define-binop logxor
2 xor
))
189 ;;; Special handling of add on the x86; can use lea to avoid a
190 ;;; register load, otherwise it uses add.
191 (define-vop (fast-+/fixnum
=>fixnum fast-safe-arith-op
)
193 (:args
(x :scs
(any-reg) :target r
194 :load-if
(not (and (sc-is x control-stack
)
196 (sc-is r control-stack
)
198 (y :scs
(any-reg control-stack
)))
199 (:arg-types tagged-num tagged-num
)
200 (:results
(r :scs
(any-reg) :from
(:argument
0)
201 :load-if
(not (and (sc-is x control-stack
)
203 (sc-is r control-stack
)
205 (:result-types tagged-num
)
206 (:note
"inline fixnum arithmetic")
208 (cond ((and (sc-is x any-reg
) (sc-is y any-reg
) (sc-is r any-reg
)
209 (not (location= x r
)))
210 (inst lea r
(make-ea :qword
:base x
:index y
:scale
1)))
215 (define-vop (fast-+-c
/fixnum
=>fixnum fast-safe-arith-op
)
217 (:args
(x :target r
:scs
(any-reg control-stack
)))
219 (:arg-types tagged-num
(:constant
(signed-byte 29)))
220 (:results
(r :scs
(any-reg)
221 :load-if
(not (location= x r
))))
222 (:result-types tagged-num
)
223 (:note
"inline fixnum arithmetic")
225 (cond ((and (sc-is x any-reg
) (sc-is r any-reg
) (not (location= x r
)))
226 (inst lea r
(make-ea :qword
:base x
:disp
(fixnumize y
))))
229 (inst add r
(fixnumize y
))))))
231 (define-vop (fast-+/signed
=>signed fast-safe-arith-op
)
233 (:args
(x :scs
(signed-reg) :target r
234 :load-if
(not (and (sc-is x signed-stack
)
236 (sc-is r signed-stack
)
238 (y :scs
(signed-reg signed-stack
)))
239 (:arg-types signed-num signed-num
)
240 (:results
(r :scs
(signed-reg) :from
(:argument
0)
241 :load-if
(not (and (sc-is x signed-stack
)
244 (:result-types signed-num
)
245 (:note
"inline (signed-byte 64) arithmetic")
247 (cond ((and (sc-is x signed-reg
) (sc-is y signed-reg
) (sc-is r signed-reg
)
248 (not (location= x r
)))
249 (inst lea r
(make-ea :qword
:base x
:index y
:scale
1)))
255 ;;;; Special logand cases: (logand signed unsigned) => unsigned
257 (define-vop (fast-logand/signed-unsigned
=>unsigned
258 fast-logand
/unsigned
=>unsigned
)
259 (:args
(x :target r
:scs
(signed-reg)
260 :load-if
(not (and (sc-is x signed-stack
)
261 (sc-is y unsigned-reg
)
262 (sc-is r unsigned-stack
)
264 (y :scs
(unsigned-reg unsigned-stack
)))
265 (:arg-types signed-num unsigned-num
))
267 (define-vop (fast-logand-c/signed-unsigned
=>unsigned
268 fast-logand-c
/unsigned
=>unsigned
)
269 (:args
(x :target r
:scs
(signed-reg signed-stack
)))
270 (:arg-types signed-num
(:constant
(unsigned-byte 31))))
272 (define-vop (fast-logand/unsigned-signed
=>unsigned
273 fast-logand
/unsigned
=>unsigned
)
274 (:args
(x :target r
:scs
(unsigned-reg)
275 :load-if
(not (and (sc-is x unsigned-stack
)
277 (sc-is r unsigned-stack
)
279 (y :scs
(signed-reg signed-stack
)))
280 (:arg-types unsigned-num signed-num
))
283 (define-vop (fast-+-c
/signed
=>signed fast-safe-arith-op
)
285 (:args
(x :target r
:scs
(signed-reg signed-stack
)))
287 (:arg-types signed-num
(:constant
(signed-byte 32)))
288 (:results
(r :scs
(signed-reg)
289 :load-if
(not (location= x r
))))
290 (:result-types signed-num
)
291 (:note
"inline (signed-byte 64) arithmetic")
293 (cond ((and (sc-is x signed-reg
) (sc-is r signed-reg
)
294 (not (location= x r
)))
295 (inst lea r
(make-ea :qword
:base x
:disp y
)))
302 (define-vop (fast-+/unsigned
=>unsigned fast-safe-arith-op
)
304 (:args
(x :scs
(unsigned-reg) :target r
305 :load-if
(not (and (sc-is x unsigned-stack
)
306 (sc-is y unsigned-reg
)
307 (sc-is r unsigned-stack
)
309 (y :scs
(unsigned-reg unsigned-stack
)))
310 (:arg-types unsigned-num unsigned-num
)
311 (:results
(r :scs
(unsigned-reg) :from
(:argument
0)
312 :load-if
(not (and (sc-is x unsigned-stack
)
313 (sc-is y unsigned-reg
)
314 (sc-is r unsigned-stack
)
316 (:result-types unsigned-num
)
317 (:note
"inline (unsigned-byte 64) arithmetic")
319 (cond ((and (sc-is x unsigned-reg
) (sc-is y unsigned-reg
)
320 (sc-is r unsigned-reg
) (not (location= x r
)))
321 (inst lea r
(make-ea :qword
:base x
:index y
:scale
1)))
326 (define-vop (fast-+-c
/unsigned
=>unsigned fast-safe-arith-op
)
328 (:args
(x :target r
:scs
(unsigned-reg unsigned-stack
)))
330 (:arg-types unsigned-num
(:constant
(unsigned-byte 31)))
331 (:results
(r :scs
(unsigned-reg)
332 :load-if
(not (location= x r
))))
333 (:result-types unsigned-num
)
334 (:note
"inline (unsigned-byte 64) arithmetic")
336 (cond ((and (sc-is x unsigned-reg
) (sc-is r unsigned-reg
)
337 (not (location= x r
)))
338 (inst lea r
(make-ea :qword
:base x
:disp y
)))
345 ;;;; multiplication and division
347 (define-vop (fast-*/fixnum
=>fixnum fast-safe-arith-op
)
349 ;; We need different loading characteristics.
350 (:args
(x :scs
(any-reg) :target r
)
351 (y :scs
(any-reg control-stack
)))
352 (:arg-types tagged-num tagged-num
)
353 (:results
(r :scs
(any-reg) :from
(:argument
0)))
354 (:result-types tagged-num
)
355 (:note
"inline fixnum arithmetic")
361 (define-vop (fast-*-c
/fixnum
=>fixnum fast-safe-arith-op
)
363 ;; We need different loading characteristics.
364 (:args
(x :scs
(any-reg control-stack
)))
366 (:arg-types tagged-num
(:constant
(signed-byte 29)))
367 (:results
(r :scs
(any-reg)))
368 (:result-types tagged-num
)
369 (:note
"inline fixnum arithmetic")
373 (define-vop (fast-*/signed
=>signed fast-safe-arith-op
)
375 ;; We need different loading characteristics.
376 (:args
(x :scs
(signed-reg) :target r
)
377 (y :scs
(signed-reg signed-stack
)))
378 (:arg-types signed-num signed-num
)
379 (:results
(r :scs
(signed-reg) :from
(:argument
0)))
380 (:result-types signed-num
)
381 (:note
"inline (signed-byte 64) arithmetic")
386 (define-vop (fast-*-c
/signed
=>signed fast-safe-arith-op
)
388 ;; We need different loading characteristics.
389 (:args
(x :scs
(signed-reg signed-stack
)))
391 (:arg-types signed-num
(:constant
(signed-byte 32)))
392 (:results
(r :scs
(signed-reg)))
393 (:result-types signed-num
)
394 (:note
"inline (signed-byte 64) arithmetic")
398 (define-vop (fast-*/unsigned
=>unsigned fast-safe-arith-op
)
400 (:args
(x :scs
(unsigned-reg) :target eax
)
401 (y :scs
(unsigned-reg unsigned-stack
)))
402 (:arg-types unsigned-num unsigned-num
)
403 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target r
404 :from
(:argument
0) :to
:result
) eax
)
405 (:temporary
(:sc unsigned-reg
:offset edx-offset
406 :from
:eval
:to
:result
) edx
)
408 (:results
(r :scs
(unsigned-reg)))
409 (:result-types unsigned-num
)
410 (:note
"inline (unsigned-byte 64) arithmetic")
412 (:save-p
:compute-only
)
419 (define-vop (fast-truncate/fixnum
=>fixnum fast-safe-arith-op
)
420 (:translate truncate
)
421 (:args
(x :scs
(any-reg) :target eax
)
422 (y :scs
(any-reg control-stack
)))
423 (:arg-types tagged-num tagged-num
)
424 (:temporary
(:sc signed-reg
:offset eax-offset
:target quo
425 :from
(:argument
0) :to
(:result
0)) eax
)
426 (:temporary
(:sc unsigned-reg
:offset edx-offset
:target rem
427 :from
(:argument
0) :to
(:result
1)) edx
)
428 (:results
(quo :scs
(any-reg))
429 (rem :scs
(any-reg)))
430 (:result-types tagged-num tagged-num
)
431 (:note
"inline fixnum arithmetic")
433 (:save-p
:compute-only
)
435 (let ((zero (generate-error-code vop
'division-by-zero-error x y
)))
436 (if (sc-is y any-reg
)
437 (inst test y y
) ; smaller instruction
443 (if (location= quo eax
)
445 (inst lea quo
(make-ea :qword
:index eax
:scale
8)))
448 (define-vop (fast-truncate-c/fixnum
=>fixnum fast-safe-arith-op
)
449 (:translate truncate
)
450 (:args
(x :scs
(any-reg) :target eax
))
452 (:arg-types tagged-num
(:constant
(signed-byte 29)))
453 (:temporary
(:sc signed-reg
:offset eax-offset
:target quo
454 :from
:argument
:to
(:result
0)) eax
)
455 (:temporary
(:sc any-reg
:offset edx-offset
:target rem
456 :from
:eval
:to
(:result
1)) edx
)
457 (:temporary
(:sc any-reg
:from
:eval
:to
:result
) y-arg
)
458 (:results
(quo :scs
(any-reg))
459 (rem :scs
(any-reg)))
460 (:result-types tagged-num tagged-num
)
461 (:note
"inline fixnum arithmetic")
463 (:save-p
:compute-only
)
467 (inst mov y-arg
(fixnumize y
))
468 (inst idiv eax y-arg
)
469 (if (location= quo eax
)
471 (inst lea quo
(make-ea :qword
:index eax
:scale
8)))
474 (define-vop (fast-truncate/unsigned
=>unsigned fast-safe-arith-op
)
475 (:translate truncate
)
476 (:args
(x :scs
(unsigned-reg) :target eax
)
477 (y :scs
(unsigned-reg signed-stack
)))
478 (:arg-types unsigned-num unsigned-num
)
479 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target quo
480 :from
(:argument
0) :to
(:result
0)) eax
)
481 (:temporary
(:sc unsigned-reg
:offset edx-offset
:target rem
482 :from
(:argument
0) :to
(:result
1)) edx
)
483 (:results
(quo :scs
(unsigned-reg))
484 (rem :scs
(unsigned-reg)))
485 (:result-types unsigned-num unsigned-num
)
486 (:note
"inline (unsigned-byte 64) arithmetic")
488 (:save-p
:compute-only
)
490 (let ((zero (generate-error-code vop
'division-by-zero-error x y
)))
491 (if (sc-is y unsigned-reg
)
492 (inst test y y
) ; smaller instruction
501 (define-vop (fast-truncate-c/unsigned
=>unsigned fast-safe-arith-op
)
502 (:translate truncate
)
503 (:args
(x :scs
(unsigned-reg) :target eax
))
505 (:arg-types unsigned-num
(:constant
(unsigned-byte 31)))
506 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target quo
507 :from
:argument
:to
(:result
0)) eax
)
508 (:temporary
(:sc unsigned-reg
:offset edx-offset
:target rem
509 :from
:eval
:to
(:result
1)) edx
)
510 (:temporary
(:sc unsigned-reg
:from
:eval
:to
:result
) y-arg
)
511 (:results
(quo :scs
(unsigned-reg))
512 (rem :scs
(unsigned-reg)))
513 (:result-types unsigned-num unsigned-num
)
514 (:note
"inline (unsigned-byte 64) arithmetic")
516 (:save-p
:compute-only
)
525 (define-vop (fast-truncate/signed
=>signed fast-safe-arith-op
)
526 (:translate truncate
)
527 (:args
(x :scs
(signed-reg) :target eax
)
528 (y :scs
(signed-reg signed-stack
)))
529 (:arg-types signed-num signed-num
)
530 (:temporary
(:sc signed-reg
:offset eax-offset
:target quo
531 :from
(:argument
0) :to
(:result
0)) eax
)
532 (:temporary
(:sc signed-reg
:offset edx-offset
:target rem
533 :from
(:argument
0) :to
(:result
1)) edx
)
534 (:results
(quo :scs
(signed-reg))
535 (rem :scs
(signed-reg)))
536 (:result-types signed-num signed-num
)
537 (:note
"inline (signed-byte 64) arithmetic")
539 (:save-p
:compute-only
)
541 (let ((zero (generate-error-code vop
'division-by-zero-error x y
)))
542 (if (sc-is y signed-reg
)
543 (inst test y y
) ; smaller instruction
552 (define-vop (fast-truncate-c/signed
=>signed fast-safe-arith-op
)
553 (:translate truncate
)
554 (:args
(x :scs
(signed-reg) :target eax
))
556 (:arg-types signed-num
(:constant
(signed-byte 32)))
557 (:temporary
(:sc signed-reg
:offset eax-offset
:target quo
558 :from
:argument
:to
(:result
0)) eax
)
559 (:temporary
(:sc signed-reg
:offset edx-offset
:target rem
560 :from
:eval
:to
(:result
1)) edx
)
561 (:temporary
(:sc signed-reg
:from
:eval
:to
:result
) y-arg
)
562 (:results
(quo :scs
(signed-reg))
563 (rem :scs
(signed-reg)))
564 (:result-types signed-num signed-num
)
565 (:note
"inline (signed-byte 64) arithmetic")
567 (:save-p
:compute-only
)
572 (inst idiv eax y-arg
)
579 (define-vop (fast-ash-c/fixnum
=>fixnum
)
582 (:args
(number :scs
(any-reg) :target result
583 :load-if
(not (and (sc-is number any-reg control-stack
)
584 (sc-is result any-reg control-stack
)
585 (location= number result
)))))
587 (:arg-types tagged-num
(:constant integer
))
588 (:results
(result :scs
(any-reg)
589 :load-if
(not (and (sc-is number control-stack
)
590 (sc-is result control-stack
)
591 (location= number result
)))))
592 (:result-types tagged-num
)
595 (cond ((and (= amount
1) (not (location= number result
)))
596 (inst lea result
(make-ea :qword
:base number
:index number
)))
597 ((and (= amount
2) (not (location= number result
)))
598 (inst lea result
(make-ea :qword
:index number
:scale
4)))
599 ((and (= amount
3) (not (location= number result
)))
600 (inst lea result
(make-ea :qword
:index number
:scale
8)))
603 (cond ((< -
64 amount
64)
604 ;; this code is used both in ASH and ASH-SMOD61, so
607 (inst shl result amount
)
609 (inst sar result
(- amount
))
610 (inst and result
(lognot fixnum-tag-mask
)))))
612 (if (sc-is result any-reg
)
613 (inst xor result result
)
614 (inst mov result
0)))
615 (t (inst sar result
63)
616 (inst and result
(lognot fixnum-tag-mask
))))))))
618 (define-vop (fast-ash-left/fixnum
=>fixnum
)
620 (:args
(number :scs
(any-reg) :target result
621 :load-if
(not (and (sc-is number control-stack
)
622 (sc-is result control-stack
)
623 (location= number result
))))
624 (amount :scs
(unsigned-reg) :target ecx
))
625 (:arg-types tagged-num positive-fixnum
)
626 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
627 (:results
(result :scs
(any-reg) :from
(:argument
0)
628 :load-if
(not (and (sc-is number control-stack
)
629 (sc-is result control-stack
)
630 (location= number result
)))))
631 (:result-types tagged-num
)
637 ;; The result-type ensures us that this shift will not overflow.
638 (inst shl result
:cl
)))
640 (define-vop (fast-ash-c/signed
=>signed
)
643 (:args
(number :scs
(signed-reg) :target result
644 :load-if
(not (and (sc-is number signed-stack
)
645 (sc-is result signed-stack
)
646 (location= number result
)))))
648 (:arg-types signed-num
(:constant integer
))
649 (:results
(result :scs
(signed-reg)
650 :load-if
(not (and (sc-is number signed-stack
)
651 (sc-is result signed-stack
)
652 (location= number result
)))))
653 (:result-types signed-num
)
656 (cond ((and (= amount
1) (not (location= number result
)))
657 (inst lea result
(make-ea :qword
:base number
:index number
)))
658 ((and (= amount
2) (not (location= number result
)))
659 (inst lea result
(make-ea :qword
:index number
:scale
4)))
660 ((and (= amount
3) (not (location= number result
)))
661 (inst lea result
(make-ea :qword
:index number
:scale
8)))
664 (cond ((plusp amount
) (inst shl result amount
))
665 (t (inst sar result
(min 63 (- amount
)))))))))
667 (define-vop (fast-ash-c/unsigned
=>unsigned
)
670 (:args
(number :scs
(unsigned-reg) :target result
671 :load-if
(not (and (sc-is number unsigned-stack
)
672 (sc-is result unsigned-stack
)
673 (location= number result
)))))
675 (:arg-types unsigned-num
(:constant integer
))
676 (:results
(result :scs
(unsigned-reg)
677 :load-if
(not (and (sc-is number unsigned-stack
)
678 (sc-is result unsigned-stack
)
679 (location= number result
)))))
680 (:result-types unsigned-num
)
683 (cond ((and (= amount
1) (not (location= number result
)))
684 (inst lea result
(make-ea :qword
:base number
:index number
)))
685 ((and (= amount
2) (not (location= number result
)))
686 (inst lea result
(make-ea :qword
:index number
:scale
4)))
687 ((and (= amount
3) (not (location= number result
)))
688 (inst lea result
(make-ea :qword
:index number
:scale
8)))
691 (cond ((< -
64 amount
64) ;; XXXX
692 ;; this code is used both in ASH and ASH-MOD32, so
695 (inst shl result amount
)
696 (inst shr result
(- amount
))))
697 (t (if (sc-is result unsigned-reg
)
699 (inst mov result
0))))))))
701 (define-vop (fast-ash-left/signed
=>signed
)
703 (:args
(number :scs
(signed-reg) :target result
704 :load-if
(not (and (sc-is number signed-stack
)
705 (sc-is result signed-stack
)
706 (location= number result
))))
707 (amount :scs
(unsigned-reg) :target ecx
))
708 (:arg-types signed-num positive-fixnum
)
709 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
710 (:results
(result :scs
(signed-reg) :from
(:argument
0)
711 :load-if
(not (and (sc-is number signed-stack
)
712 (sc-is result signed-stack
)
713 (location= number result
)))))
714 (:result-types signed-num
)
720 (inst shl result
:cl
)))
722 (define-vop (fast-ash-left/unsigned
=>unsigned
)
724 (:args
(number :scs
(unsigned-reg) :target result
725 :load-if
(not (and (sc-is number unsigned-stack
)
726 (sc-is result unsigned-stack
)
727 (location= number result
))))
728 (amount :scs
(unsigned-reg) :target ecx
))
729 (:arg-types unsigned-num positive-fixnum
)
730 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
731 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)
732 :load-if
(not (and (sc-is number unsigned-stack
)
733 (sc-is result unsigned-stack
)
734 (location= number result
)))))
735 (:result-types unsigned-num
)
741 (inst shl result
:cl
)))
743 (define-vop (fast-ash/signed
=>signed
)
746 (:args
(number :scs
(signed-reg) :target result
)
747 (amount :scs
(signed-reg) :target ecx
))
748 (:arg-types signed-num signed-num
)
749 (:results
(result :scs
(signed-reg) :from
(:argument
0)))
750 (:result-types signed-num
)
751 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
757 (inst jmp
:ns POSITIVE
)
763 (inst sar result
:cl
)
767 ;; The result-type ensures us that this shift will not overflow.
768 (inst shl result
:cl
)
772 (define-vop (fast-ash/unsigned
=>unsigned
)
775 (:args
(number :scs
(unsigned-reg) :target result
)
776 (amount :scs
(signed-reg) :target ecx
))
777 (:arg-types unsigned-num signed-num
)
778 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)))
779 (:result-types unsigned-num
)
780 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
786 (inst jmp
:ns POSITIVE
)
793 (inst shr result
:cl
)
797 ;; The result-type ensures us that this shift will not overflow.
798 (inst shl result
:cl
)
804 (defknown %lea
(integer integer
(member 1 2 4 8 16) (signed-byte 64))
806 (foldable flushable movable
))
808 (defoptimizer (%lea derive-type
) ((base index scale disp
))
809 (when (and (constant-lvar-p scale
)
810 (constant-lvar-p disp
))
811 (let ((scale (lvar-value scale
))
812 (disp (lvar-value disp
))
813 (base-type (lvar-type base
))
814 (index-type (lvar-type index
)))
815 (when (and (numeric-type-p base-type
)
816 (numeric-type-p index-type
))
817 (let ((base-lo (numeric-type-low base-type
))
818 (base-hi (numeric-type-high base-type
))
819 (index-lo (numeric-type-low index-type
))
820 (index-hi (numeric-type-high index-type
)))
821 (make-numeric-type :class
'integer
823 :low
(when (and base-lo index-lo
)
824 (+ base-lo
(* index-lo scale
) disp
))
825 :high
(when (and base-hi index-hi
)
826 (+ base-hi
(* index-hi scale
) disp
))))))))
828 (defun %lea
(base index scale disp
)
829 (+ base
(* index scale
) disp
))
833 (define-vop (%lea
/unsigned
=>unsigned
)
836 (:args
(base :scs
(unsigned-reg))
837 (index :scs
(unsigned-reg)))
839 (:arg-types unsigned-num unsigned-num
840 (:constant
(member 1 2 4 8))
841 (:constant
(signed-byte 64)))
842 (:results
(r :scs
(unsigned-reg)))
843 (:result-types unsigned-num
)
845 (inst lea r
(make-ea :qword
:base base
:index index
846 :scale scale
:disp disp
))))
848 (define-vop (%lea
/signed
=>signed
)
851 (:args
(base :scs
(signed-reg))
852 (index :scs
(signed-reg)))
854 (:arg-types signed-num signed-num
855 (:constant
(member 1 2 4 8))
856 (:constant
(signed-byte 64)))
857 (:results
(r :scs
(signed-reg)))
858 (:result-types signed-num
)
860 (inst lea r
(make-ea :qword
:base base
:index index
861 :scale scale
:disp disp
))))
863 (define-vop (%lea
/fixnum
=>fixnum
)
866 (:args
(base :scs
(any-reg))
867 (index :scs
(any-reg)))
869 (:arg-types tagged-num tagged-num
870 (:constant
(member 1 2 4 8))
871 (:constant
(signed-byte 64)))
872 (:results
(r :scs
(any-reg)))
873 (:result-types tagged-num
)
875 (inst lea r
(make-ea :qword
:base base
:index index
876 :scale scale
:disp disp
))))
878 ;;; FIXME: before making knowledge of this too public, it needs to be
879 ;;; fixed so that it's actually _faster_ than the non-CMOV version; at
880 ;;; least on my Celeron-XXX laptop, this version is marginally slower
881 ;;; than the above version with branches. -- CSR, 2003-09-04
882 (define-vop (fast-cmov-ash/unsigned
=>unsigned
)
885 (:args
(number :scs
(unsigned-reg) :target result
)
886 (amount :scs
(signed-reg) :target ecx
))
887 (:arg-types unsigned-num signed-num
)
888 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)))
889 (:result-types unsigned-num
)
890 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
891 (:temporary
(:sc any-reg
:from
(:eval
0) :to
(:eval
1)) zero
)
893 (:guard
(member :cmov
*backend-subfeatures
*))
898 (inst jmp
:ns POSITIVE
)
901 (inst shr result
:cl
)
903 (inst cmov
:nbe result zero
)
907 ;; The result-type ensures us that this shift will not overflow.
908 (inst shl result
:cl
)
912 (define-vop (signed-byte-64-len)
913 (:translate integer-length
)
914 (:note
"inline (signed-byte 64) integer-length")
916 (:args
(arg :scs
(signed-reg) :target res
))
917 (:arg-types signed-num
)
918 (:results
(res :scs
(unsigned-reg)))
919 (:result-types unsigned-num
)
922 (if (sc-is res unsigned-reg
)
936 (define-vop (unsigned-byte-64-len)
937 (:translate integer-length
)
938 (:note
"inline (unsigned-byte 64) integer-length")
940 (:args
(arg :scs
(unsigned-reg)))
941 (:arg-types unsigned-num
)
942 (:results
(res :scs
(unsigned-reg)))
943 (:result-types unsigned-num
)
953 (define-vop (unsigned-byte-64-count)
954 (:translate logcount
)
955 (:note
"inline (unsigned-byte 64) logcount")
957 (:args
(arg :scs
(unsigned-reg) :target result
))
958 (:arg-types unsigned-num
)
959 (:results
(result :scs
(unsigned-reg)))
960 (:result-types positive-fixnum
)
961 (:temporary
(:sc unsigned-reg
) temp
)
962 (:temporary
(:sc unsigned-reg
) mask
)
964 ;; See the comments below for how the algorithm works. The tricks
965 ;; used can be found for example in AMD's software optimization
966 ;; guide or at "http://www.hackersdelight.org/HDcode/pop.cc" in the
967 ;; function "pop1", for 32-bit words. The extension to 64 bits is
969 ;; Calculate 2-bit sums. Note that the value of a two-digit binary
970 ;; number is the sum of the right digit and twice the left digit.
971 ;; Thus we can calculate the sum of the two digits by shifting the
972 ;; left digit to the right position and doing a two-bit subtraction.
973 ;; This subtraction will never create a borrow and thus can be made
974 ;; on all 32 2-digit numbers at once.
978 (inst mov mask
#x5555555555555555
)
979 (inst and result mask
)
980 (inst sub temp result
)
981 ;; Calculate 4-bit sums by straightforward shift, mask and add.
982 ;; Note that we shift the source operand of the MOV and not its
983 ;; destination so that the SHR and the MOV can execute in the same
985 (inst mov result temp
)
987 (inst mov mask
#x3333333333333333
)
988 (inst and result mask
)
990 (inst add result temp
)
991 ;; Calculate 8-bit sums. Since each sum is at most 8, which fits
992 ;; into 4 bits, we can apply the mask after the addition, saving one
994 (inst mov temp result
)
996 (inst add result temp
)
997 (inst mov mask
#x0f0f0f0f0f0f0f0f
)
998 (inst and result mask
)
999 ;; Add all 8 bytes at once by multiplying with #256r11111111.
1000 ;; We need to calculate only the lower 8 bytes of the product.
1001 ;; Of these the most significant byte contains the final result.
1002 ;; Note that there can be no overflow from one byte to the next
1003 ;; as the sum is at most 64 which needs only 7 bits.
1004 (inst mov mask
#x0101010101010101
)
1005 (inst imul result mask
)
1006 (inst shr result
56)))
1008 ;;;; binary conditional VOPs
1010 (define-vop (fast-conditional)
1012 (:info target not-p
)
1015 (:policy
:fast-safe
))
1017 ;;; constant variants are declared for 32 bits not 64 bits, because
1018 ;;; loading a 64 bit constant is silly
1020 (define-vop (fast-conditional/fixnum fast-conditional
)
1021 (:args
(x :scs
(any-reg)
1022 :load-if
(not (and (sc-is x control-stack
)
1023 (sc-is y any-reg
))))
1024 (y :scs
(any-reg control-stack
)))
1025 (:arg-types tagged-num tagged-num
)
1026 (:note
"inline fixnum comparison"))
1028 (define-vop (fast-conditional-c/fixnum fast-conditional
/fixnum
)
1029 (:args
(x :scs
(any-reg control-stack
)))
1030 (:arg-types tagged-num
(:constant
(signed-byte 29)))
1031 (:info target not-p y
))
1033 (define-vop (fast-conditional/signed fast-conditional
)
1034 (:args
(x :scs
(signed-reg)
1035 :load-if
(not (and (sc-is x signed-stack
)
1036 (sc-is y signed-reg
))))
1037 (y :scs
(signed-reg signed-stack
)))
1038 (:arg-types signed-num signed-num
)
1039 (:note
"inline (signed-byte 64) comparison"))
1041 (define-vop (fast-conditional-c/signed fast-conditional
/signed
)
1042 (:args
(x :scs
(signed-reg signed-stack
)))
1043 (:arg-types signed-num
(:constant
(signed-byte 31)))
1044 (:info target not-p y
))
1046 (define-vop (fast-conditional/unsigned fast-conditional
)
1047 (:args
(x :scs
(unsigned-reg)
1048 :load-if
(not (and (sc-is x unsigned-stack
)
1049 (sc-is y unsigned-reg
))))
1050 (y :scs
(unsigned-reg unsigned-stack
)))
1051 (:arg-types unsigned-num unsigned-num
)
1052 (:note
"inline (unsigned-byte 64) comparison"))
1054 (define-vop (fast-conditional-c/unsigned fast-conditional
/unsigned
)
1055 (:args
(x :scs
(unsigned-reg unsigned-stack
)))
1056 (:arg-types unsigned-num
(:constant
(unsigned-byte 31)))
1057 (:info target not-p y
))
1059 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned
)
1062 (lambda (suffix cost signed
)
1063 `(define-vop (;; FIXME: These could be done more
1064 ;; cleanly with SYMBOLICATE.
1065 ,(intern (format nil
"~:@(FAST-IF-~A~A~)"
1068 (format nil
"~:@(FAST-CONDITIONAL~A~)"
1073 ,(if (eq suffix
'-c
/fixnum
)
1084 '(/fixnum -c
/fixnum
/signed -c
/signed
/unsigned -c
/unsigned
)
1085 ; '(/fixnum /signed /unsigned)
1087 '(t t t t nil nil
)))))
1089 (define-conditional-vop < :l
:b
:ge
:ae
)
1090 (define-conditional-vop > :g
:a
:le
:be
))
1092 (define-vop (fast-if-eql/signed fast-conditional
/signed
)
1096 (inst jmp
(if not-p
:ne
:e
) target
)))
1098 (define-vop (fast-if-eql-c/signed fast-conditional-c
/signed
)
1101 (cond ((and (sc-is x signed-reg
) (zerop y
))
1102 (inst test x x
)) ; smaller instruction
1105 (inst jmp
(if not-p
:ne
:e
) target
)))
1107 (define-vop (fast-if-eql/unsigned fast-conditional
/unsigned
)
1111 (inst jmp
(if not-p
:ne
:e
) target
)))
1113 (define-vop (fast-if-eql-c/unsigned fast-conditional-c
/unsigned
)
1116 (cond ((and (sc-is x unsigned-reg
) (zerop y
))
1117 (inst test x x
)) ; smaller instruction
1120 (inst jmp
(if not-p
:ne
:e
) target
)))
1122 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
1125 ;;; These versions specify a fixnum restriction on their first arg. We have
1126 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
1127 ;;; the first arg and a higher cost. The reason for doing this is to prevent
1128 ;;; fixnum specific operations from being used on word integers, spuriously
1129 ;;; consing the argument.
1131 (define-vop (fast-eql/fixnum fast-conditional
)
1132 (:args
(x :scs
(any-reg)
1133 :load-if
(not (and (sc-is x control-stack
)
1134 (sc-is y any-reg
))))
1135 (y :scs
(any-reg control-stack
)))
1136 (:arg-types tagged-num tagged-num
)
1137 (:note
"inline fixnum comparison")
1141 (inst jmp
(if not-p
:ne
:e
) target
)))
1142 (define-vop (generic-eql/fixnum fast-eql
/fixnum
)
1143 (:args
(x :scs
(any-reg descriptor-reg
)
1144 :load-if
(not (and (sc-is x control-stack
)
1145 (sc-is y any-reg
))))
1146 (y :scs
(any-reg control-stack
)))
1147 (:arg-types
* tagged-num
)
1151 (define-vop (fast-eql-c/fixnum fast-conditional
/fixnum
)
1152 (:args
(x :scs
(any-reg control-stack
)))
1153 (:arg-types tagged-num
(:constant
(signed-byte 29)))
1154 (:info target not-p y
)
1157 (cond ((and (sc-is x any-reg
) (zerop y
))
1158 (inst test x x
)) ; smaller instruction
1160 (inst cmp x
(fixnumize y
))))
1161 (inst jmp
(if not-p
:ne
:e
) target
)))
1163 (define-vop (generic-eql-c/fixnum fast-eql-c
/fixnum
)
1164 (:args
(x :scs
(any-reg descriptor-reg control-stack
)))
1165 (:arg-types
* (:constant
(signed-byte 29)))
1168 ;;;; 32-bit logical operations
1170 (define-vop (merge-bits)
1171 (:translate merge-bits
)
1172 (:args
(shift :scs
(signed-reg unsigned-reg
) :target ecx
)
1173 (prev :scs
(unsigned-reg) :target result
)
1174 (next :scs
(unsigned-reg)))
1175 (:arg-types tagged-num unsigned-num unsigned-num
)
1176 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
0)) ecx
)
1177 (:results
(result :scs
(unsigned-reg) :from
(:argument
1)))
1178 (:result-types unsigned-num
)
1179 (:policy
:fast-safe
)
1183 (inst shrd result next
:cl
)))
1185 ;;; Only the lower 6 bits of the shift amount are significant.
1186 (define-vop (shift-towards-someplace)
1187 (:policy
:fast-safe
)
1188 (:args
(num :scs
(unsigned-reg) :target r
)
1189 (amount :scs
(signed-reg) :target ecx
))
1190 (:arg-types unsigned-num tagged-num
)
1191 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
1192 (:results
(r :scs
(unsigned-reg) :from
(:argument
0)))
1193 (:result-types unsigned-num
))
1195 (define-vop (shift-towards-start shift-towards-someplace
)
1196 (:translate shift-towards-start
)
1197 (:note
"SHIFT-TOWARDS-START")
1203 (define-vop (shift-towards-end shift-towards-someplace
)
1204 (:translate shift-towards-end
)
1205 (:note
"SHIFT-TOWARDS-END")
1211 ;;;; Modular functions
1213 (defmacro define-mod-binop
((name prototype
) function
)
1214 `(define-vop (,name
,prototype
)
1215 (:args
(x :target r
:scs
(unsigned-reg signed-reg
)
1216 :load-if
(not (and (or (sc-is x unsigned-stack
)
1217 (sc-is x signed-stack
))
1218 (or (sc-is y unsigned-reg
)
1219 (sc-is y signed-reg
))
1220 (or (sc-is r unsigned-stack
)
1221 (sc-is r signed-stack
))
1223 (y :scs
(unsigned-reg signed-reg unsigned-stack signed-stack
)))
1224 (:arg-types untagged-num untagged-num
)
1225 (:results
(r :scs
(unsigned-reg signed-reg
) :from
(:argument
0)
1226 :load-if
(not (and (or (sc-is x unsigned-stack
)
1227 (sc-is x signed-stack
))
1228 (or (sc-is y unsigned-reg
)
1229 (sc-is y unsigned-reg
))
1230 (or (sc-is r unsigned-stack
)
1231 (sc-is r unsigned-stack
))
1233 (:result-types unsigned-num
)
1234 (:translate
,function
)))
1235 (defmacro define-mod-binop-c
((name prototype
) function
)
1236 `(define-vop (,name
,prototype
)
1237 (:args
(x :target r
:scs
(unsigned-reg signed-reg
)
1238 :load-if
(not (and (or (sc-is x unsigned-stack
)
1239 (sc-is x signed-stack
))
1240 (or (sc-is r unsigned-stack
)
1241 (sc-is r signed-stack
))
1244 (:arg-types untagged-num
(:constant
(or (unsigned-byte 31) (signed-byte 32))))
1245 (:results
(r :scs
(unsigned-reg signed-reg
) :from
(:argument
0)
1246 :load-if
(not (and (or (sc-is x unsigned-stack
)
1247 (sc-is x signed-stack
))
1248 (or (sc-is r unsigned-stack
)
1249 (sc-is r unsigned-stack
))
1251 (:result-types unsigned-num
)
1252 (:translate
,function
)))
1254 (macrolet ((def (name -c-p
)
1255 (let ((fun64 (intern (format nil
"~S-MOD64" name
)))
1256 (vopu (intern (format nil
"FAST-~S/UNSIGNED=>UNSIGNED" name
)))
1257 (vopcu (intern (format nil
"FAST-~S-C/UNSIGNED=>UNSIGNED" name
)))
1258 (vopf (intern (format nil
"FAST-~S/FIXNUM=>FIXNUM" name
)))
1259 (vopcf (intern (format nil
"FAST-~S-C/FIXNUM=>FIXNUM" name
)))
1260 (vop64u (intern (format nil
"FAST-~S-MOD64/WORD=>UNSIGNED" name
)))
1261 (vop64f (intern (format nil
"FAST-~S-MOD64/FIXNUM=>FIXNUM" name
)))
1262 (vop64cu (intern (format nil
"FAST-~S-MOD64-C/WORD=>UNSIGNED" name
)))
1263 (vop64cf (intern (format nil
"FAST-~S-MOD64-C/FIXNUM=>FIXNUM" name
)))
1264 (sfun61 (intern (format nil
"~S-SMOD61" name
)))
1265 (svop61f (intern (format nil
"FAST-~S-SMOD61/FIXNUM=>FIXNUM" name
)))
1266 (svop61cf (intern (format nil
"FAST-~S-SMOD61-C/FIXNUM=>FIXNUM" name
))))
1268 (define-modular-fun ,fun64
(x y
) ,name
:untagged nil
64)
1269 (define-modular-fun ,sfun61
(x y
) ,name
:tagged t
61)
1270 (define-mod-binop (,vop64u
,vopu
) ,fun64
)
1271 (define-vop (,vop64f
,vopf
) (:translate
,fun64
))
1272 (define-vop (,svop61f
,vopf
) (:translate
,sfun61
))
1274 `((define-mod-binop-c (,vop64cu
,vopcu
) ,fun64
)
1275 (define-vop (,svop61cf
,vopcf
) (:translate
,sfun61
))))))))
1278 ;; (no -C variant as x86 MUL instruction doesn't take an immediate)
1281 (define-vop (fast-ash-left-mod64-c/unsigned
=>unsigned
1282 fast-ash-c
/unsigned
=>unsigned
)
1283 (:translate ash-left-mod64
))
1284 (define-vop (fast-ash-left-mod64/unsigned
=>unsigned
1285 fast-ash-left
/unsigned
=>unsigned
))
1286 (deftransform ash-left-mod64
((integer count
)
1287 ((unsigned-byte 64) (unsigned-byte 6)))
1288 (when (sb!c
::constant-lvar-p count
)
1289 (sb!c
::give-up-ir1-transform
))
1290 '(%primitive fast-ash-left-mod64
/unsigned
=>unsigned integer count
))
1292 (define-vop (fast-ash-left-smod61-c/fixnum
=>fixnum
1293 fast-ash-c
/fixnum
=>fixnum
)
1294 (:translate ash-left-smod61
))
1295 (define-vop (fast-ash-left-smod61/fixnum
=>fixnum
1296 fast-ash-left
/fixnum
=>fixnum
))
1297 (deftransform ash-left-smod61
((integer count
)
1298 ((signed-byte 61) (unsigned-byte 6)))
1299 (when (sb!c
::constant-lvar-p count
)
1300 (sb!c
::give-up-ir1-transform
))
1301 '(%primitive fast-ash-left-smod61
/fixnum
=>fixnum integer count
))
1305 (defknown sb
!vm
::%lea-mod64
(integer integer
(member 1 2 4 8) (signed-byte 64))
1307 (foldable flushable movable
))
1308 (defknown sb
!vm
::%lea-smod61
(integer integer
(member 1 2 4 8) (signed-byte 64))
1310 (foldable flushable movable
))
1312 (define-modular-fun-optimizer %lea
((base index scale disp
) :untagged nil
:width width
)
1313 (when (and (<= width
64)
1314 (constant-lvar-p scale
)
1315 (constant-lvar-p disp
))
1316 (cut-to-width base
:untagged width nil
)
1317 (cut-to-width index
:untagged width nil
)
1318 'sb
!vm
::%lea-mod64
))
1319 (define-modular-fun-optimizer %lea
((base index scale disp
) :tagged t
:width width
)
1320 (when (and (<= width
61)
1321 (constant-lvar-p scale
)
1322 (constant-lvar-p disp
))
1323 (cut-to-width base
:tagged width t
)
1324 (cut-to-width index
:tagged width t
)
1325 'sb
!vm
::%lea-smod61
))
1329 (defun sb!vm
::%lea-mod64
(base index scale disp
)
1330 (ldb (byte 64 0) (%lea base index scale disp
)))
1331 (defun sb!vm
::%lea-smod61
(base index scale disp
)
1332 (mask-signed-field 61 (%lea base index scale disp
))))
1335 (defun sb!vm
::%lea-mod64
(base index scale disp
)
1336 (let ((base (logand base
#xffffffffffffffff
))
1337 (index (logand index
#xffffffffffffffff
)))
1338 ;; can't use modular version of %LEA, as we only have VOPs for
1339 ;; constant SCALE and DISP.
1340 (ldb (byte 64 0) (+ base
(* index scale
) disp
))))
1341 (defun sb!vm
::%lea-smod61
(base index scale disp
)
1342 (let ((base (mask-signed-field 61 base
))
1343 (index (mask-signed-field 61 index
)))
1344 ;; can't use modular version of %LEA, as we only have VOPs for
1345 ;; constant SCALE and DISP.
1346 (mask-signed-field 61 (+ base
(* index scale
) disp
)))))
1348 (in-package "SB!VM")
1350 (define-vop (%lea-mod64
/unsigned
=>unsigned
1351 %lea
/unsigned
=>unsigned
)
1352 (:translate %lea-mod64
))
1353 (define-vop (%lea-smod61
/fixnum
=>fixnum
1354 %lea
/fixnum
=>fixnum
)
1355 (:translate %lea-smod61
))
1357 ;;; logical operations
1358 (define-modular-fun lognot-mod64
(x) lognot
:untagged nil
64)
1359 (define-vop (lognot-mod64/unsigned
=>unsigned
)
1360 (:translate lognot-mod64
)
1361 (:args
(x :scs
(unsigned-reg unsigned-stack
) :target r
1362 :load-if
(not (and (sc-is x unsigned-stack
)
1363 (sc-is r unsigned-stack
)
1365 (:arg-types unsigned-num
)
1366 (:results
(r :scs
(unsigned-reg)
1367 :load-if
(not (and (sc-is x unsigned-stack
)
1368 (sc-is r unsigned-stack
)
1370 (:result-types unsigned-num
)
1371 (:policy
:fast-safe
)
1376 (define-source-transform logeqv
(&rest args
)
1377 (if (oddp (length args
))
1379 `(lognot (logxor ,@args
))))
1380 (define-source-transform logandc1
(x y
)
1381 `(logand (lognot ,x
) ,y
))
1382 (define-source-transform logandc2
(x y
)
1383 `(logand ,x
(lognot ,y
)))
1384 (define-source-transform logorc1
(x y
)
1385 `(logior (lognot ,x
) ,y
))
1386 (define-source-transform logorc2
(x y
)
1387 `(logior ,x
(lognot ,y
)))
1388 (define-source-transform lognor
(x y
)
1389 `(lognot (logior ,x
,y
)))
1390 (define-source-transform lognand
(x y
)
1391 `(lognot (logand ,x
,y
)))
1395 (define-vop (bignum-length get-header-data
)
1396 (:translate sb
!bignum
:%bignum-length
)
1397 (:policy
:fast-safe
))
1399 (define-vop (bignum-set-length set-header-data
)
1400 (:translate sb
!bignum
:%bignum-set-length
)
1401 (:policy
:fast-safe
))
1403 (define-full-reffer bignum-ref
* bignum-digits-offset other-pointer-lowtag
1404 (unsigned-reg) unsigned-num sb
!bignum
:%bignum-ref
)
1405 (define-full-reffer+offset bignum--ref-with-offset
* bignum-digits-offset
1406 other-pointer-lowtag
(unsigned-reg) unsigned-num
1407 sb
!bignum
:%bignum-ref-with-offset
)
1408 (define-full-setter bignum-set
* bignum-digits-offset other-pointer-lowtag
1409 (unsigned-reg) unsigned-num sb
!bignum
:%bignum-set
)
1411 (define-vop (digit-0-or-plus)
1412 (:translate sb
!bignum
:%digit-0-or-plusp
)
1413 (:policy
:fast-safe
)
1414 (:args
(digit :scs
(unsigned-reg)))
1415 (:arg-types unsigned-num
)
1417 (:info target not-p
)
1419 (inst or digit digit
)
1420 (inst jmp
(if not-p
:s
:ns
) target
)))
1423 ;;; For add and sub with carry the sc of carry argument is any-reg so
1424 ;;; that it may be passed as a fixnum or word and thus may be 0, 1, or
1425 ;;; 8. This is easy to deal with and may save a fixnum-word
1427 (define-vop (add-w/carry
)
1428 (:translate sb
!bignum
:%add-with-carry
)
1429 (:policy
:fast-safe
)
1430 (:args
(a :scs
(unsigned-reg) :target result
)
1431 (b :scs
(unsigned-reg unsigned-stack
) :to
:eval
)
1432 (c :scs
(any-reg) :target temp
))
1433 (:arg-types unsigned-num unsigned-num positive-fixnum
)
1434 (:temporary
(:sc any-reg
:from
(:argument
2) :to
:eval
) temp
)
1435 (:results
(result :scs
(unsigned-reg) :from
(:argument
0))
1436 (carry :scs
(unsigned-reg)))
1437 (:result-types unsigned-num positive-fixnum
)
1441 (inst neg temp
) ; Set the carry flag to 0 if c=0 else to 1
1444 (inst adc carry carry
)))
1446 ;;; Note: the borrow is 1 for no borrow and 0 for a borrow, the opposite
1447 ;;; of the x86-64 convention.
1448 (define-vop (sub-w/borrow
)
1449 (:translate sb
!bignum
:%subtract-with-borrow
)
1450 (:policy
:fast-safe
)
1451 (:args
(a :scs
(unsigned-reg) :to
:eval
:target result
)
1452 (b :scs
(unsigned-reg unsigned-stack
) :to
:result
)
1453 (c :scs
(any-reg control-stack
)))
1454 (:arg-types unsigned-num unsigned-num positive-fixnum
)
1455 (:results
(result :scs
(unsigned-reg) :from
:eval
)
1456 (borrow :scs
(unsigned-reg)))
1457 (:result-types unsigned-num positive-fixnum
)
1459 (inst cmp c
1) ; Set the carry flag to 1 if c=0 else to 0
1463 (inst sbb borrow
0)))
1466 (define-vop (bignum-mult-and-add-3-arg)
1467 (:translate sb
!bignum
:%multiply-and-add
)
1468 (:policy
:fast-safe
)
1469 (:args
(x :scs
(unsigned-reg) :target eax
)
1470 (y :scs
(unsigned-reg unsigned-stack
))
1471 (carry-in :scs
(unsigned-reg unsigned-stack
)))
1472 (:arg-types unsigned-num unsigned-num unsigned-num
)
1473 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0)
1474 :to
(:result
1) :target lo
) eax
)
1475 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
1)
1476 :to
(:result
0) :target hi
) edx
)
1477 (:results
(hi :scs
(unsigned-reg))
1478 (lo :scs
(unsigned-reg)))
1479 (:result-types unsigned-num unsigned-num
)
1483 (inst add eax carry-in
)
1488 (define-vop (bignum-mult-and-add-4-arg)
1489 (:translate sb
!bignum
:%multiply-and-add
)
1490 (:policy
:fast-safe
)
1491 (:args
(x :scs
(unsigned-reg) :target eax
)
1492 (y :scs
(unsigned-reg unsigned-stack
))
1493 (prev :scs
(unsigned-reg unsigned-stack
))
1494 (carry-in :scs
(unsigned-reg unsigned-stack
)))
1495 (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num
)
1496 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0)
1497 :to
(:result
1) :target lo
) eax
)
1498 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
1)
1499 :to
(:result
0) :target hi
) edx
)
1500 (:results
(hi :scs
(unsigned-reg))
1501 (lo :scs
(unsigned-reg)))
1502 (:result-types unsigned-num unsigned-num
)
1508 (inst add eax carry-in
)
1514 (define-vop (bignum-mult)
1515 (:translate sb
!bignum
:%multiply
)
1516 (:policy
:fast-safe
)
1517 (:args
(x :scs
(unsigned-reg) :target eax
)
1518 (y :scs
(unsigned-reg unsigned-stack
)))
1519 (:arg-types unsigned-num unsigned-num
)
1520 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0)
1521 :to
(:result
1) :target lo
) eax
)
1522 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
1)
1523 :to
(:result
0) :target hi
) edx
)
1524 (:results
(hi :scs
(unsigned-reg))
1525 (lo :scs
(unsigned-reg)))
1526 (:result-types unsigned-num unsigned-num
)
1533 (define-vop (bignum-lognot lognot-mod64
/unsigned
=>unsigned
)
1534 (:translate sb
!bignum
:%lognot
))
1536 (define-vop (fixnum-to-digit)
1537 (:translate sb
!bignum
:%fixnum-to-digit
)
1538 (:policy
:fast-safe
)
1539 (:args
(fixnum :scs
(any-reg control-stack
) :target digit
))
1540 (:arg-types tagged-num
)
1541 (:results
(digit :scs
(unsigned-reg)
1542 :load-if
(not (and (sc-is fixnum control-stack
)
1543 (sc-is digit unsigned-stack
)
1544 (location= fixnum digit
)))))
1545 (:result-types unsigned-num
)
1548 (inst sar digit
3)))
1550 (define-vop (bignum-floor)
1551 (:translate sb
!bignum
:%floor
)
1552 (:policy
:fast-safe
)
1553 (:args
(div-high :scs
(unsigned-reg) :target edx
)
1554 (div-low :scs
(unsigned-reg) :target eax
)
1555 (divisor :scs
(unsigned-reg unsigned-stack
)))
1556 (:arg-types unsigned-num unsigned-num unsigned-num
)
1557 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
1)
1558 :to
(:result
0) :target quo
) eax
)
1559 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
0)
1560 :to
(:result
1) :target rem
) edx
)
1561 (:results
(quo :scs
(unsigned-reg))
1562 (rem :scs
(unsigned-reg)))
1563 (:result-types unsigned-num unsigned-num
)
1567 (inst div eax divisor
)
1571 (define-vop (signify-digit)
1572 (:translate sb
!bignum
:%fixnum-digit-with-correct-sign
)
1573 (:policy
:fast-safe
)
1574 (:args
(digit :scs
(unsigned-reg unsigned-stack
) :target res
))
1575 (:arg-types unsigned-num
)
1576 (:results
(res :scs
(any-reg signed-reg
)
1577 :load-if
(not (and (sc-is digit unsigned-stack
)
1578 (sc-is res control-stack signed-stack
)
1579 (location= digit res
)))))
1580 (:result-types signed-num
)
1583 (when (sc-is res any-reg control-stack
)
1586 (define-vop (digit-ashr)
1587 (:translate sb
!bignum
:%ashr
)
1588 (:policy
:fast-safe
)
1589 (:args
(digit :scs
(unsigned-reg unsigned-stack
) :target result
)
1590 (count :scs
(unsigned-reg) :target ecx
))
1591 (:arg-types unsigned-num positive-fixnum
)
1592 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
1593 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)
1594 :load-if
(not (and (sc-is result unsigned-stack
)
1595 (location= digit result
)))))
1596 (:result-types unsigned-num
)
1600 (inst sar result
:cl
)))
1602 (define-vop (digit-ashr/c
)
1603 (:translate sb
!bignum
:%ashr
)
1604 (:policy
:fast-safe
)
1605 (:args
(digit :scs
(unsigned-reg unsigned-stack
) :target result
))
1606 (:arg-types unsigned-num
(:constant
(integer 0 63)))
1608 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)
1609 :load-if
(not (and (sc-is result unsigned-stack
)
1610 (location= digit result
)))))
1611 (:result-types unsigned-num
)
1614 (inst sar result count
)))
1616 (define-vop (digit-lshr digit-ashr
)
1617 (:translate sb
!bignum
:%digit-logical-shift-right
)
1621 (inst shr result
:cl
)))
1623 (define-vop (digit-ashl digit-ashr
)
1624 (:translate sb
!bignum
:%ashl
)
1628 (inst shl result
:cl
)))
1630 ;;;; static functions
1632 (define-static-fun two-arg-
/ (x y
) :translate
/)
1634 (define-static-fun two-arg-gcd
(x y
) :translate gcd
)
1635 (define-static-fun two-arg-lcm
(x y
) :translate lcm
)
1637 (define-static-fun two-arg-and
(x y
) :translate logand
)
1638 (define-static-fun two-arg-ior
(x y
) :translate logior
)
1639 (define-static-fun two-arg-xor
(x y
) :translate logxor
)
1644 (defun *-transformer
(y)
1646 ((= y
(ash 1 (integer-length y
)))
1647 ;; there's a generic transform for y = 2^k
1648 (give-up-ir1-transform))
1649 ((member y
'(3 5 9))
1650 ;; we can do these multiplications directly using LEA
1651 `(%lea x x
,(1- y
) 0))
1653 ;; A normal 64-bit multiplication takes 4 cycles on Athlon 64/Opteron.
1654 ;; Optimizing multiplications (other than the above cases) to
1655 ;; shifts/adds/leas gives a maximum improvement of 1 cycle, but requires
1656 ;; quite a lot of hairy code.
1657 (give-up-ir1-transform))))
1659 (deftransform * ((x y
)
1660 ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1662 "recode as leas, shifts and adds"
1663 (let ((y (lvar-value y
)))
1665 (deftransform sb
!vm
::*-mod64
1666 ((x y
) ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1668 "recode as leas, shifts and adds"
1669 (let ((y (lvar-value y
)))
1672 (deftransform * ((x y
)
1673 ((signed-byte 61) (constant-arg (unsigned-byte 64)))
1675 "recode as leas, shifts and adds"
1676 (let ((y (lvar-value y
)))
1678 (deftransform sb
!vm
::*-smod61
1679 ((x y
) ((signed-byte 61) (constant-arg (unsigned-byte 64)))
1681 "recode as leas, shifts and adds"
1682 (let ((y (lvar-value y
)))