1 ;;;; the VM definition of arithmetic VOPs for the x86
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
)
934 (define-vop (unsigned-byte-64-len)
935 (:translate integer-length
)
936 (:note
"inline (unsigned-byte 64) integer-length")
938 (:args
(arg :scs
(unsigned-reg)))
939 (:arg-types unsigned-num
)
940 (:results
(res :scs
(unsigned-reg)))
941 (:result-types unsigned-num
)
951 (define-vop (unsigned-byte-64-count)
952 (:translate logcount
)
953 (:note
"inline (unsigned-byte 64) logcount")
955 (:args
(arg :scs
(unsigned-reg) :target result
))
956 (:arg-types unsigned-num
)
957 (:results
(result :scs
(unsigned-reg)))
958 (:result-types positive-fixnum
)
959 (:temporary
(:sc unsigned-reg
) temp
)
960 (:temporary
(:sc unsigned-reg
) mask
)
962 ;; See the comments below for how the algorithm works. The tricks
963 ;; used can be found for example in AMD's software optimization
964 ;; guide or at "http://www.hackersdelight.org/HDcode/pop.cc" in the
965 ;; function "pop1", for 32-bit words. The extension to 64 bits is
967 ;; Calculate 2-bit sums. Note that the value of a two-digit binary
968 ;; number is the sum of the right digit and twice the left digit.
969 ;; Thus we can calculate the sum of the two digits by shifting the
970 ;; left digit to the right position and doing a two-bit subtraction.
971 ;; This subtraction will never create a borrow and thus can be made
972 ;; on all 32 2-digit numbers at once.
976 (inst mov mask
#x5555555555555555
)
977 (inst and result mask
)
978 (inst sub temp result
)
979 ;; Calculate 4-bit sums by straightforward shift, mask and add.
980 ;; Note that we shift the source operand of the MOV and not its
981 ;; destination so that the SHR and the MOV can execute in the same
983 (inst mov result temp
)
985 (inst mov mask
#x3333333333333333
)
986 (inst and result mask
)
988 (inst add result temp
)
989 ;; Calculate 8-bit sums. Since each sum is at most 8, which fits
990 ;; into 4 bits, we can apply the mask after the addition, saving one
992 (inst mov temp result
)
994 (inst add result temp
)
995 (inst mov mask
#x0f0f0f0f0f0f0f0f
)
996 (inst and result mask
)
997 ;; Add all 8 bytes at once by multiplying with #256r11111111.
998 ;; We need to calculate only the lower 8 bytes of the product.
999 ;; Of these the most significant byte contains the final result.
1000 ;; Note that there can be no overflow from one byte to the next
1001 ;; as the sum is at most 64 which needs only 7 bits.
1002 (inst mov mask
#x0101010101010101
)
1003 (inst imul result mask
)
1004 (inst shr result
56)))
1006 ;;;; binary conditional VOPs
1008 (define-vop (fast-conditional)
1010 (:info target not-p
)
1013 (:policy
:fast-safe
))
1015 ;;; constant variants are declared for 32 bits not 64 bits, because
1016 ;;; loading a 64 bit constant is silly
1018 (define-vop (fast-conditional/fixnum fast-conditional
)
1019 (:args
(x :scs
(any-reg)
1020 :load-if
(not (and (sc-is x control-stack
)
1021 (sc-is y any-reg
))))
1022 (y :scs
(any-reg control-stack
)))
1023 (:arg-types tagged-num tagged-num
)
1024 (:note
"inline fixnum comparison"))
1026 (define-vop (fast-conditional-c/fixnum fast-conditional
/fixnum
)
1027 (:args
(x :scs
(any-reg control-stack
)))
1028 (:arg-types tagged-num
(:constant
(signed-byte 29)))
1029 (:info target not-p y
))
1031 (define-vop (fast-conditional/signed fast-conditional
)
1032 (:args
(x :scs
(signed-reg)
1033 :load-if
(not (and (sc-is x signed-stack
)
1034 (sc-is y signed-reg
))))
1035 (y :scs
(signed-reg signed-stack
)))
1036 (:arg-types signed-num signed-num
)
1037 (:note
"inline (signed-byte 64) comparison"))
1039 (define-vop (fast-conditional-c/signed fast-conditional
/signed
)
1040 (:args
(x :scs
(signed-reg signed-stack
)))
1041 (:arg-types signed-num
(:constant
(signed-byte 31)))
1042 (:info target not-p y
))
1044 (define-vop (fast-conditional/unsigned fast-conditional
)
1045 (:args
(x :scs
(unsigned-reg)
1046 :load-if
(not (and (sc-is x unsigned-stack
)
1047 (sc-is y unsigned-reg
))))
1048 (y :scs
(unsigned-reg unsigned-stack
)))
1049 (:arg-types unsigned-num unsigned-num
)
1050 (:note
"inline (unsigned-byte 64) comparison"))
1052 (define-vop (fast-conditional-c/unsigned fast-conditional
/unsigned
)
1053 (:args
(x :scs
(unsigned-reg unsigned-stack
)))
1054 (:arg-types unsigned-num
(:constant
(unsigned-byte 31)))
1055 (:info target not-p y
))
1057 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned
)
1060 (lambda (suffix cost signed
)
1061 `(define-vop (;; FIXME: These could be done more
1062 ;; cleanly with SYMBOLICATE.
1063 ,(intern (format nil
"~:@(FAST-IF-~A~A~)"
1066 (format nil
"~:@(FAST-CONDITIONAL~A~)"
1071 ,(if (eq suffix
'-c
/fixnum
)
1082 '(/fixnum -c
/fixnum
/signed -c
/signed
/unsigned -c
/unsigned
)
1083 ; '(/fixnum /signed /unsigned)
1085 '(t t t t nil nil
)))))
1087 (define-conditional-vop < :l
:b
:ge
:ae
)
1088 (define-conditional-vop > :g
:a
:le
:be
))
1090 (define-vop (fast-if-eql/signed fast-conditional
/signed
)
1094 (inst jmp
(if not-p
:ne
:e
) target
)))
1096 (define-vop (fast-if-eql-c/signed fast-conditional-c
/signed
)
1099 (cond ((and (sc-is x signed-reg
) (zerop y
))
1100 (inst test x x
)) ; smaller instruction
1103 (inst jmp
(if not-p
:ne
:e
) target
)))
1105 (define-vop (fast-if-eql/unsigned fast-conditional
/unsigned
)
1109 (inst jmp
(if not-p
:ne
:e
) target
)))
1111 (define-vop (fast-if-eql-c/unsigned fast-conditional-c
/unsigned
)
1114 (cond ((and (sc-is x unsigned-reg
) (zerop y
))
1115 (inst test x x
)) ; smaller instruction
1118 (inst jmp
(if not-p
:ne
:e
) target
)))
1120 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
1123 ;;; These versions specify a fixnum restriction on their first arg. We have
1124 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
1125 ;;; the first arg and a higher cost. The reason for doing this is to prevent
1126 ;;; fixnum specific operations from being used on word integers, spuriously
1127 ;;; consing the argument.
1129 (define-vop (fast-eql/fixnum fast-conditional
)
1130 (:args
(x :scs
(any-reg)
1131 :load-if
(not (and (sc-is x control-stack
)
1132 (sc-is y any-reg
))))
1133 (y :scs
(any-reg control-stack
)))
1134 (:arg-types tagged-num tagged-num
)
1135 (:note
"inline fixnum comparison")
1139 (inst jmp
(if not-p
:ne
:e
) target
)))
1140 (define-vop (generic-eql/fixnum fast-eql
/fixnum
)
1141 (:args
(x :scs
(any-reg descriptor-reg
)
1142 :load-if
(not (and (sc-is x control-stack
)
1143 (sc-is y any-reg
))))
1144 (y :scs
(any-reg control-stack
)))
1145 (:arg-types
* tagged-num
)
1149 (define-vop (fast-eql-c/fixnum fast-conditional
/fixnum
)
1150 (:args
(x :scs
(any-reg control-stack
)))
1151 (:arg-types tagged-num
(:constant
(signed-byte 29)))
1152 (:info target not-p y
)
1155 (cond ((and (sc-is x any-reg
) (zerop y
))
1156 (inst test x x
)) ; smaller instruction
1158 (inst cmp x
(fixnumize y
))))
1159 (inst jmp
(if not-p
:ne
:e
) target
)))
1161 (define-vop (generic-eql-c/fixnum fast-eql-c
/fixnum
)
1162 (:args
(x :scs
(any-reg descriptor-reg control-stack
)))
1163 (:arg-types
* (:constant
(signed-byte 29)))
1166 ;;;; 32-bit logical operations
1168 (define-vop (merge-bits)
1169 (:translate merge-bits
)
1170 (:args
(shift :scs
(signed-reg unsigned-reg
) :target ecx
)
1171 (prev :scs
(unsigned-reg) :target result
)
1172 (next :scs
(unsigned-reg)))
1173 (:arg-types tagged-num unsigned-num unsigned-num
)
1174 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
0)) ecx
)
1175 (:results
(result :scs
(unsigned-reg) :from
(:argument
1)))
1176 (:result-types unsigned-num
)
1177 (:policy
:fast-safe
)
1181 (inst shrd result next
:cl
)))
1183 ;;; Only the lower 6 bits of the shift amount are significant.
1184 (define-vop (shift-towards-someplace)
1185 (:policy
:fast-safe
)
1186 (:args
(num :scs
(unsigned-reg) :target r
)
1187 (amount :scs
(signed-reg) :target ecx
))
1188 (:arg-types unsigned-num tagged-num
)
1189 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
1190 (:results
(r :scs
(unsigned-reg) :from
(:argument
0)))
1191 (:result-types unsigned-num
))
1193 (define-vop (shift-towards-start shift-towards-someplace
)
1194 (:translate shift-towards-start
)
1195 (:note
"SHIFT-TOWARDS-START")
1201 (define-vop (shift-towards-end shift-towards-someplace
)
1202 (:translate shift-towards-end
)
1203 (:note
"SHIFT-TOWARDS-END")
1209 ;;;; Modular functions
1211 (defmacro define-mod-binop
((name prototype
) function
)
1212 `(define-vop (,name
,prototype
)
1213 (:args
(x :target r
:scs
(unsigned-reg signed-reg
)
1214 :load-if
(not (and (or (sc-is x unsigned-stack
)
1215 (sc-is x signed-stack
))
1216 (or (sc-is y unsigned-reg
)
1217 (sc-is y signed-reg
))
1218 (or (sc-is r unsigned-stack
)
1219 (sc-is r signed-stack
))
1221 (y :scs
(unsigned-reg signed-reg unsigned-stack signed-stack
)))
1222 (:arg-types untagged-num untagged-num
)
1223 (:results
(r :scs
(unsigned-reg signed-reg
) :from
(:argument
0)
1224 :load-if
(not (and (or (sc-is x unsigned-stack
)
1225 (sc-is x signed-stack
))
1226 (or (sc-is y unsigned-reg
)
1227 (sc-is y unsigned-reg
))
1228 (or (sc-is r unsigned-stack
)
1229 (sc-is r unsigned-stack
))
1231 (:result-types unsigned-num
)
1232 (:translate
,function
)))
1233 (defmacro define-mod-binop-c
((name prototype
) function
)
1234 `(define-vop (,name
,prototype
)
1235 (:args
(x :target r
:scs
(unsigned-reg signed-reg
)
1236 :load-if
(not (and (or (sc-is x unsigned-stack
)
1237 (sc-is x signed-stack
))
1238 (or (sc-is r unsigned-stack
)
1239 (sc-is r signed-stack
))
1242 (:arg-types untagged-num
(:constant
(or (unsigned-byte 31) (signed-byte 32))))
1243 (:results
(r :scs
(unsigned-reg signed-reg
) :from
(:argument
0)
1244 :load-if
(not (and (or (sc-is x unsigned-stack
)
1245 (sc-is x signed-stack
))
1246 (or (sc-is r unsigned-stack
)
1247 (sc-is r unsigned-stack
))
1249 (:result-types unsigned-num
)
1250 (:translate
,function
)))
1252 (macrolet ((def (name -c-p
)
1253 (let ((fun64 (intern (format nil
"~S-MOD64" name
)))
1254 (vopu (intern (format nil
"FAST-~S/UNSIGNED=>UNSIGNED" name
)))
1255 (vopcu (intern (format nil
"FAST-~S-C/UNSIGNED=>UNSIGNED" name
)))
1256 (vopf (intern (format nil
"FAST-~S/FIXNUM=>FIXNUM" name
)))
1257 (vopcf (intern (format nil
"FAST-~S-C/FIXNUM=>FIXNUM" name
)))
1258 (vop64u (intern (format nil
"FAST-~S-MOD64/WORD=>UNSIGNED" name
)))
1259 (vop64f (intern (format nil
"FAST-~S-MOD64/FIXNUM=>FIXNUM" name
)))
1260 (vop64cu (intern (format nil
"FAST-~S-MOD64-C/WORD=>UNSIGNED" name
)))
1261 (vop64cf (intern (format nil
"FAST-~S-MOD64-C/FIXNUM=>FIXNUM" name
)))
1262 (sfun61 (intern (format nil
"~S-SMOD61" name
)))
1263 (svop61f (intern (format nil
"FAST-~S-SMOD61/FIXNUM=>FIXNUM" name
)))
1264 (svop61cf (intern (format nil
"FAST-~S-SMOD61-C/FIXNUM=>FIXNUM" name
))))
1266 (define-modular-fun ,fun64
(x y
) ,name
:unsigned
64)
1267 (define-modular-fun ,sfun61
(x y
) ,name
:signed
61)
1268 (define-mod-binop (,vop64u
,vopu
) ,fun64
)
1269 (define-vop (,vop64f
,vopf
) (:translate
,fun64
))
1270 (define-vop (,svop61f
,vopf
) (:translate
,sfun61
))
1272 `((define-mod-binop-c (,vop64cu
,vopcu
) ,fun64
)
1273 (define-vop (,svop61cf
,vopcf
) (:translate
,sfun61
))))))))
1276 ;; (no -C variant as x86 MUL instruction doesn't take an immediate)
1279 (define-vop (fast-ash-left-mod64-c/unsigned
=>unsigned
1280 fast-ash-c
/unsigned
=>unsigned
)
1281 (:translate ash-left-mod64
))
1282 (define-vop (fast-ash-left-mod64/unsigned
=>unsigned
1283 fast-ash-left
/unsigned
=>unsigned
))
1284 (deftransform ash-left-mod64
((integer count
)
1285 ((unsigned-byte 64) (unsigned-byte 6)))
1286 (when (sb!c
::constant-lvar-p count
)
1287 (sb!c
::give-up-ir1-transform
))
1288 '(%primitive fast-ash-left-mod64
/unsigned
=>unsigned integer count
))
1290 (define-vop (fast-ash-left-smod61-c/fixnum
=>fixnum
1291 fast-ash-c
/fixnum
=>fixnum
)
1292 (:translate ash-left-smod61
))
1293 (define-vop (fast-ash-left-smod61/fixnum
=>fixnum
1294 fast-ash-left
/fixnum
=>fixnum
))
1295 (deftransform ash-left-smod61
((integer count
)
1296 ((signed-byte 61) (unsigned-byte 6)))
1297 (when (sb!c
::constant-lvar-p count
)
1298 (sb!c
::give-up-ir1-transform
))
1299 '(%primitive fast-ash-left-smod61
/fixnum
=>fixnum integer count
))
1303 (defknown sb
!vm
::%lea-mod64
(integer integer
(member 1 2 4 8) (signed-byte 64))
1305 (foldable flushable movable
))
1306 (defknown sb
!vm
::%lea-smod61
(integer integer
(member 1 2 4 8) (signed-byte 64))
1308 (foldable flushable movable
))
1310 (define-modular-fun-optimizer %lea
((base index scale disp
) :unsigned
:width width
)
1311 (when (and (<= width
64)
1312 (constant-lvar-p scale
)
1313 (constant-lvar-p disp
))
1314 (cut-to-width base
:unsigned width
)
1315 (cut-to-width index
:unsigned width
)
1316 'sb
!vm
::%lea-mod64
))
1317 (define-modular-fun-optimizer %lea
((base index scale disp
) :signed
:width width
)
1318 (when (and (<= width
61)
1319 (constant-lvar-p scale
)
1320 (constant-lvar-p disp
))
1321 (cut-to-width base
:signed width
)
1322 (cut-to-width index
:signed width
)
1323 'sb
!vm
::%lea-smod61
))
1327 (defun sb!vm
::%lea-mod64
(base index scale disp
)
1328 (ldb (byte 64 0) (%lea base index scale disp
)))
1329 (defun sb!vm
::%lea-smod61
(base index scale disp
)
1330 (mask-signed-field 61 (%lea base index scale disp
))))
1333 (defun sb!vm
::%lea-mod64
(base index scale disp
)
1334 (let ((base (logand base
#xffffffffffffffff
))
1335 (index (logand index
#xffffffffffffffff
)))
1336 ;; can't use modular version of %LEA, as we only have VOPs for
1337 ;; constant SCALE and DISP.
1338 (ldb (byte 64 0) (+ base
(* index scale
) disp
))))
1339 (defun sb!vm
::%lea-smod61
(base index scale disp
)
1340 (let ((base (mask-signed-field 61 base
))
1341 (index (mask-signed-field 61 index
)))
1342 ;; can't use modular version of %LEA, as we only have VOPs for
1343 ;; constant SCALE and DISP.
1344 (mask-signed-field 61 (+ base
(* index scale
) disp
)))))
1346 (in-package "SB!VM")
1348 (define-vop (%lea-mod64
/unsigned
=>unsigned
1349 %lea
/unsigned
=>unsigned
)
1350 (:translate %lea-mod64
))
1351 (define-vop (%lea-smod61
/fixnum
=>fixnum
1352 %lea
/fixnum
=>fixnum
)
1353 (:translate %lea-smod61
))
1355 ;;; logical operations
1356 (define-modular-fun lognot-mod64
(x) lognot
:unsigned
64)
1357 (define-vop (lognot-mod64/unsigned
=>unsigned
)
1358 (:translate lognot-mod64
)
1359 (:args
(x :scs
(unsigned-reg unsigned-stack
) :target r
1360 :load-if
(not (and (sc-is x unsigned-stack
)
1361 (sc-is r unsigned-stack
)
1363 (:arg-types unsigned-num
)
1364 (:results
(r :scs
(unsigned-reg)
1365 :load-if
(not (and (sc-is x unsigned-stack
)
1366 (sc-is r unsigned-stack
)
1368 (:result-types unsigned-num
)
1369 (:policy
:fast-safe
)
1374 (define-modular-fun logxor-mod64
(x y
) logxor
:unsigned
64)
1375 (define-mod-binop (fast-logxor-mod64/word
=>unsigned
1376 fast-logxor
/unsigned
=>unsigned
)
1378 (define-mod-binop-c (fast-logxor-mod64-c/word
=>unsigned
1379 fast-logxor-c
/unsigned
=>unsigned
)
1381 (define-vop (fast-logxor-mod64/fixnum
=>fixnum
1382 fast-logxor
/fixnum
=>fixnum
)
1383 (:translate logxor-mod64
))
1384 (define-vop (fast-logxor-mod64-c/fixnum
=>fixnum
1385 fast-logxor-c
/fixnum
=>fixnum
)
1386 (:translate logxor-mod64
))
1388 (define-source-transform logeqv
(&rest args
)
1389 (if (oddp (length args
))
1391 `(lognot (logxor ,@args
))))
1392 (define-source-transform logandc1
(x y
)
1393 `(logand (lognot ,x
) ,y
))
1394 (define-source-transform logandc2
(x y
)
1395 `(logand ,x
(lognot ,y
)))
1396 (define-source-transform logorc1
(x y
)
1397 `(logior (lognot ,x
) ,y
))
1398 (define-source-transform logorc2
(x y
)
1399 `(logior ,x
(lognot ,y
)))
1400 (define-source-transform lognor
(x y
)
1401 `(lognot (logior ,x
,y
)))
1402 (define-source-transform lognand
(x y
)
1403 `(lognot (logand ,x
,y
)))
1407 (define-vop (bignum-length get-header-data
)
1408 (:translate sb
!bignum
:%bignum-length
)
1409 (:policy
:fast-safe
))
1411 (define-vop (bignum-set-length set-header-data
)
1412 (:translate sb
!bignum
:%bignum-set-length
)
1413 (:policy
:fast-safe
))
1415 (define-full-reffer bignum-ref
* bignum-digits-offset other-pointer-lowtag
1416 (unsigned-reg) unsigned-num sb
!bignum
:%bignum-ref
)
1417 (define-full-reffer+offset bignum--ref-with-offset
* bignum-digits-offset
1418 other-pointer-lowtag
(unsigned-reg) unsigned-num
1419 sb
!bignum
:%bignum-ref-with-offset
)
1420 (define-full-setter bignum-set
* bignum-digits-offset other-pointer-lowtag
1421 (unsigned-reg) unsigned-num sb
!bignum
:%bignum-set
)
1423 (define-vop (digit-0-or-plus)
1424 (:translate sb
!bignum
:%digit-0-or-plusp
)
1425 (:policy
:fast-safe
)
1426 (:args
(digit :scs
(unsigned-reg)))
1427 (:arg-types unsigned-num
)
1429 (:info target not-p
)
1431 (inst or digit digit
)
1432 (inst jmp
(if not-p
:s
:ns
) target
)))
1435 ;;; For add and sub with carry the sc of carry argument is any-reg so
1436 ;;; that it may be passed as a fixnum or word and thus may be 0, 1, or
1437 ;;; 8. This is easy to deal with and may save a fixnum-word
1439 (define-vop (add-w/carry
)
1440 (:translate sb
!bignum
:%add-with-carry
)
1441 (:policy
:fast-safe
)
1442 (:args
(a :scs
(unsigned-reg) :target result
)
1443 (b :scs
(unsigned-reg unsigned-stack
) :to
:eval
)
1444 (c :scs
(any-reg) :target temp
))
1445 (:arg-types unsigned-num unsigned-num positive-fixnum
)
1446 (:temporary
(:sc any-reg
:from
(:argument
2) :to
:eval
) temp
)
1447 (:results
(result :scs
(unsigned-reg) :from
(:argument
0))
1448 (carry :scs
(unsigned-reg)))
1449 (:result-types unsigned-num positive-fixnum
)
1453 (inst neg temp
) ; Set the carry flag to 0 if c=0 else to 1
1456 (inst adc carry carry
)))
1458 ;;; Note: the borrow is 1 for no borrow and 0 for a borrow, the opposite
1459 ;;; of the x86-64 convention.
1460 (define-vop (sub-w/borrow
)
1461 (:translate sb
!bignum
:%subtract-with-borrow
)
1462 (:policy
:fast-safe
)
1463 (:args
(a :scs
(unsigned-reg) :to
:eval
:target result
)
1464 (b :scs
(unsigned-reg unsigned-stack
) :to
:result
)
1465 (c :scs
(any-reg control-stack
)))
1466 (:arg-types unsigned-num unsigned-num positive-fixnum
)
1467 (:results
(result :scs
(unsigned-reg) :from
:eval
)
1468 (borrow :scs
(unsigned-reg)))
1469 (:result-types unsigned-num positive-fixnum
)
1471 (inst cmp c
1) ; Set the carry flag to 1 if c=0 else to 0
1475 (inst sbb borrow
0)))
1478 (define-vop (bignum-mult-and-add-3-arg)
1479 (:translate sb
!bignum
:%multiply-and-add
)
1480 (:policy
:fast-safe
)
1481 (:args
(x :scs
(unsigned-reg) :target eax
)
1482 (y :scs
(unsigned-reg unsigned-stack
))
1483 (carry-in :scs
(unsigned-reg unsigned-stack
)))
1484 (:arg-types unsigned-num unsigned-num unsigned-num
)
1485 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0)
1486 :to
(:result
1) :target lo
) eax
)
1487 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
1)
1488 :to
(:result
0) :target hi
) edx
)
1489 (:results
(hi :scs
(unsigned-reg))
1490 (lo :scs
(unsigned-reg)))
1491 (:result-types unsigned-num unsigned-num
)
1495 (inst add eax carry-in
)
1500 (define-vop (bignum-mult-and-add-4-arg)
1501 (:translate sb
!bignum
:%multiply-and-add
)
1502 (:policy
:fast-safe
)
1503 (:args
(x :scs
(unsigned-reg) :target eax
)
1504 (y :scs
(unsigned-reg unsigned-stack
))
1505 (prev :scs
(unsigned-reg unsigned-stack
))
1506 (carry-in :scs
(unsigned-reg unsigned-stack
)))
1507 (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num
)
1508 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0)
1509 :to
(:result
1) :target lo
) eax
)
1510 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
1)
1511 :to
(:result
0) :target hi
) edx
)
1512 (:results
(hi :scs
(unsigned-reg))
1513 (lo :scs
(unsigned-reg)))
1514 (:result-types unsigned-num unsigned-num
)
1520 (inst add eax carry-in
)
1526 (define-vop (bignum-mult)
1527 (:translate sb
!bignum
:%multiply
)
1528 (:policy
:fast-safe
)
1529 (:args
(x :scs
(unsigned-reg) :target eax
)
1530 (y :scs
(unsigned-reg unsigned-stack
)))
1531 (:arg-types unsigned-num unsigned-num
)
1532 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0)
1533 :to
(:result
1) :target lo
) eax
)
1534 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
1)
1535 :to
(:result
0) :target hi
) edx
)
1536 (:results
(hi :scs
(unsigned-reg))
1537 (lo :scs
(unsigned-reg)))
1538 (:result-types unsigned-num unsigned-num
)
1545 (define-vop (bignum-lognot lognot-mod64
/unsigned
=>unsigned
)
1546 (:translate sb
!bignum
:%lognot
))
1548 (define-vop (fixnum-to-digit)
1549 (:translate sb
!bignum
:%fixnum-to-digit
)
1550 (:policy
:fast-safe
)
1551 (:args
(fixnum :scs
(any-reg control-stack
) :target digit
))
1552 (:arg-types tagged-num
)
1553 (:results
(digit :scs
(unsigned-reg)
1554 :load-if
(not (and (sc-is fixnum control-stack
)
1555 (sc-is digit unsigned-stack
)
1556 (location= fixnum digit
)))))
1557 (:result-types unsigned-num
)
1560 (inst sar digit
3)))
1562 (define-vop (bignum-floor)
1563 (:translate sb
!bignum
:%floor
)
1564 (:policy
:fast-safe
)
1565 (:args
(div-high :scs
(unsigned-reg) :target edx
)
1566 (div-low :scs
(unsigned-reg) :target eax
)
1567 (divisor :scs
(unsigned-reg unsigned-stack
)))
1568 (:arg-types unsigned-num unsigned-num unsigned-num
)
1569 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
1)
1570 :to
(:result
0) :target quo
) eax
)
1571 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
0)
1572 :to
(:result
1) :target rem
) edx
)
1573 (:results
(quo :scs
(unsigned-reg))
1574 (rem :scs
(unsigned-reg)))
1575 (:result-types unsigned-num unsigned-num
)
1579 (inst div eax divisor
)
1583 (define-vop (signify-digit)
1584 (:translate sb
!bignum
:%fixnum-digit-with-correct-sign
)
1585 (:policy
:fast-safe
)
1586 (:args
(digit :scs
(unsigned-reg unsigned-stack
) :target res
))
1587 (:arg-types unsigned-num
)
1588 (:results
(res :scs
(any-reg signed-reg
)
1589 :load-if
(not (and (sc-is digit unsigned-stack
)
1590 (sc-is res control-stack signed-stack
)
1591 (location= digit res
)))))
1592 (:result-types signed-num
)
1595 (when (sc-is res any-reg control-stack
)
1598 (define-vop (digit-ashr)
1599 (:translate sb
!bignum
:%ashr
)
1600 (:policy
:fast-safe
)
1601 (:args
(digit :scs
(unsigned-reg unsigned-stack
) :target result
)
1602 (count :scs
(unsigned-reg) :target ecx
))
1603 (:arg-types unsigned-num positive-fixnum
)
1604 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
1605 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)
1606 :load-if
(not (and (sc-is result unsigned-stack
)
1607 (location= digit result
)))))
1608 (:result-types unsigned-num
)
1612 (inst sar result
:cl
)))
1614 (define-vop (digit-ashr/c
)
1615 (:translate sb
!bignum
:%ashr
)
1616 (:policy
:fast-safe
)
1617 (:args
(digit :scs
(unsigned-reg unsigned-stack
) :target result
))
1618 (:arg-types unsigned-num
(:constant
(integer 0 63)))
1620 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)
1621 :load-if
(not (and (sc-is result unsigned-stack
)
1622 (location= digit result
)))))
1623 (:result-types unsigned-num
)
1626 (inst sar result count
)))
1628 (define-vop (digit-lshr digit-ashr
)
1629 (:translate sb
!bignum
:%digit-logical-shift-right
)
1633 (inst shr result
:cl
)))
1635 (define-vop (digit-ashl digit-ashr
)
1636 (:translate sb
!bignum
:%ashl
)
1640 (inst shl result
:cl
)))
1642 ;;;; static functions
1644 (define-static-fun two-arg-
/ (x y
) :translate
/)
1646 (define-static-fun two-arg-gcd
(x y
) :translate gcd
)
1647 (define-static-fun two-arg-lcm
(x y
) :translate lcm
)
1649 (define-static-fun two-arg-and
(x y
) :translate logand
)
1650 (define-static-fun two-arg-ior
(x y
) :translate logior
)
1651 (define-static-fun two-arg-xor
(x y
) :translate logxor
)
1656 (defun *-transformer
(y)
1658 ((= y
(ash 1 (integer-length y
)))
1659 ;; there's a generic transform for y = 2^k
1660 (give-up-ir1-transform))
1661 ((member y
'(3 5 9))
1662 ;; we can do these multiplications directly using LEA
1663 `(%lea x x
,(1- y
) 0))
1665 ;; A normal 64-bit multiplication takes 4 cycles on Athlon 64/Opteron.
1666 ;; Optimizing multiplications (other than the above cases) to
1667 ;; shifts/adds/leas gives a maximum improvement of 1 cycle, but requires
1668 ;; quite a lot of hairy code.
1669 (give-up-ir1-transform))))
1671 (deftransform * ((x y
)
1672 ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1674 "recode as leas, shifts and adds"
1675 (let ((y (lvar-value y
)))
1677 (deftransform sb
!vm
::*-mod64
1678 ((x y
) ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1680 "recode as leas, shifts and adds"
1681 (let ((y (lvar-value y
)))
1684 (deftransform * ((x y
)
1685 ((signed-byte 61) (constant-arg (unsigned-byte 64)))
1687 "recode as leas, shifts and adds"
1688 (let ((y (lvar-value y
)))
1690 (deftransform sb
!vm
::*-smod61
1691 ((x y
) ((signed-byte 61) (constant-arg (unsigned-byte 64)))
1693 "recode as leas, shifts and adds"
1694 (let ((y (lvar-value y
)))