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.
15 ;; If chopping X to 32 bits and sign-extending is equal to the original X,
16 ;; return the chopped X, which the CPU will always treat as signed.
17 ;; Notably this allows MOST-POSITIVE-WORD to be an immediate constant.
18 (defun immediate32-p (x)
22 (let ((chopped (sb!c
::mask-signed-field
32 x
)))
23 (and (= x
(ldb (byte 64 0) chopped
))
27 ;; If 'immediate32-p' is true, use it; otherwise use a RIP-relative constant.
28 ;; I couldn't think of a more accurate name for this other than maybe
29 ;; 'signed-immediate32-or-rip-relativize' which is just too awful.
30 (defun constantize (x)
32 (register-inline-constant :qword x
)))
36 (define-vop (fast-safe-arith-op)
41 (define-vop (fixnum-unop fast-safe-arith-op
)
42 (:args
(x :scs
(any-reg) :target res
))
43 (:results
(res :scs
(any-reg)))
44 (:note
"inline fixnum arithmetic")
45 (:arg-types tagged-num
)
46 (:result-types tagged-num
))
48 (define-vop (signed-unop fast-safe-arith-op
)
49 (:args
(x :scs
(signed-reg) :target res
))
50 (:results
(res :scs
(signed-reg)))
51 (:note
"inline (signed-byte 64) arithmetic")
52 (:arg-types signed-num
)
53 (:result-types signed-num
))
55 (define-vop (fast-negate/fixnum fixnum-unop
)
61 (define-vop (fast-negate/signed signed-unop
)
67 (define-vop (fast-lognot/fixnum fixnum-unop
)
71 (inst xor res
(fixnumize -
1))))
73 (define-vop (fast-lognot/signed signed-unop
)
79 ;;;; binary fixnum operations
81 ;;; Assume that any constant operand is the second arg...
83 (define-vop (fast-fixnum-binop fast-safe-arith-op
)
84 (:args
(x :target r
:scs
(any-reg)
85 :load-if
(not (and (sc-is x control-stack
)
87 (sc-is r control-stack
)
89 (y :scs
(any-reg control-stack
)))
90 (:arg-types tagged-num tagged-num
)
91 (:results
(r :scs
(any-reg) :from
(:argument
0)
92 :load-if
(not (and (sc-is x control-stack
)
94 (sc-is r control-stack
)
96 (:result-types tagged-num
)
97 (:note
"inline fixnum arithmetic"))
99 (define-vop (fast-unsigned-binop fast-safe-arith-op
)
100 (:args
(x :target r
:scs
(unsigned-reg)
101 :load-if
(not (and (sc-is x unsigned-stack
)
102 (sc-is y unsigned-reg
)
103 (sc-is r unsigned-stack
)
105 (y :scs
(unsigned-reg unsigned-stack
)))
106 (:arg-types unsigned-num unsigned-num
)
107 (:results
(r :scs
(unsigned-reg) :from
(:argument
0)
108 :load-if
(not (and (sc-is x unsigned-stack
)
109 (sc-is y unsigned-reg
)
110 (sc-is r unsigned-stack
)
112 (:result-types unsigned-num
)
113 (:note
"inline (unsigned-byte 64) arithmetic"))
115 (define-vop (fast-signed-binop fast-safe-arith-op
)
116 (:args
(x :target r
:scs
(signed-reg)
117 :load-if
(not (and (sc-is x signed-stack
)
119 (sc-is r signed-stack
)
121 (y :scs
(signed-reg signed-stack
)))
122 (:arg-types signed-num signed-num
)
123 (:results
(r :scs
(signed-reg) :from
(:argument
0)
124 :load-if
(not (and (sc-is x signed-stack
)
126 (sc-is r signed-stack
)
128 (:result-types signed-num
)
129 (:note
"inline (signed-byte 64) arithmetic"))
131 (define-vop (fast-fixnum-binop-c fast-safe-arith-op
)
132 (:args
(x :target r
:scs
(any-reg) :load-if t
))
134 (:arg-types tagged-num
(:constant fixnum
))
135 (:results
(r :scs
(any-reg) :load-if t
))
136 (:result-types tagged-num
)
137 (:note
"inline fixnum arithmetic"))
139 (define-vop (fast-unsigned-binop-c fast-safe-arith-op
)
140 (:args
(x :target r
:scs
(unsigned-reg) :load-if t
))
142 (:arg-types unsigned-num
(:constant
(unsigned-byte 64)))
143 (:results
(r :scs
(unsigned-reg) :load-if t
))
144 (:result-types unsigned-num
)
145 (:note
"inline (unsigned-byte 64) arithmetic"))
147 (define-vop (fast-signed-binop-c fast-safe-arith-op
)
148 (:args
(x :target r
:scs
(signed-reg) :load-if t
))
150 (:arg-types signed-num
(:constant
(signed-byte 64)))
151 (:results
(r :scs
(signed-reg) :load-if t
))
152 (:result-types signed-num
)
153 (:note
"inline (signed-byte 64) arithmetic"))
155 (macrolet ((define-binop (translate untagged-penalty op
156 &key fixnum
=>fixnum c
/fixnum
=>fixnum
157 signed
=>signed c
/signed
=>signed
158 unsigned
=>unsigned c
/unsigned
=>unsigned
)
161 (define-vop (,(symbolicate "FAST-" translate
"/FIXNUM=>FIXNUM")
163 (:translate
,translate
)
165 ,@(or fixnum
=>fixnum
`((move r x
) (inst ,op r y
)))))
166 (define-vop (,(symbolicate 'fast- translate
'-c
/fixnum
=>fixnum
)
168 (:translate
,translate
)
170 ,@(or c
/fixnum
=>fixnum
172 (inst ,op r
(constantize (fixnumize y
)))))))
173 (define-vop (,(symbolicate "FAST-" translate
"/SIGNED=>SIGNED")
175 (:translate
,translate
)
176 (:generator
,(1+ untagged-penalty
)
177 ,@(or signed
=>signed
`((move r x
) (inst ,op r y
)))))
178 (define-vop (,(symbolicate 'fast- translate
'-c
/signed
=>signed
)
180 (:translate
,translate
)
181 (:generator
,untagged-penalty
182 ,@(or c
/signed
=>signed
183 `((move r x
) (inst ,op r
(constantize y
))))))
184 (define-vop (,(symbolicate "FAST-"
186 "/UNSIGNED=>UNSIGNED")
188 (:translate
,translate
)
189 (:generator
,(1+ untagged-penalty
)
190 ,@(or unsigned
=>unsigned
`((move r x
) (inst ,op r y
)))))
191 (define-vop (,(symbolicate 'fast-
193 '-c
/unsigned
=>unsigned
)
194 fast-unsigned-binop-c
)
195 (:translate
,translate
)
196 (:generator
,untagged-penalty
197 ,@(or c
/unsigned
=>unsigned
198 `((move r x
) (inst ,op r
(constantize y
)))))))))
200 ;;(define-binop + 4 add)
201 (define-binop -
4 sub
)
203 ;; The following have microoptimizations for some special cases
204 ;; not caught by the front end.
206 (define-binop logand
2 and
207 :c
/unsigned
=>unsigned
209 (let ((y (constantize y
)))
210 ;; ANDing with #xFFFF_FFFF_FFFF_FFFF is a no-op, other than
211 ;; the eflags state which we don't care about.
212 (unless (eql y -
1) ; do nothing if this is true
215 (define-binop logior
2 or
216 :c
/unsigned
=>unsigned
217 ((let ((y (constantize y
)))
218 (cond ((and (register-p r
) (eql y -
1)) ; special-case "OR reg, all-ones"
219 ;; I have yet to elicit this case. Can it happen?
225 (define-binop logxor
2 xor
226 :c
/unsigned
=>unsigned
228 (let ((y (constantize y
)))
229 (if (eql y -
1) ; special-case "XOR reg, [all-ones]"
233 ;;; Special handling of add on the x86; can use lea to avoid a
234 ;;; register load, otherwise it uses add.
235 ;;; FIXME: either inherit from fast-foo-binop or explain why not.
236 (define-vop (fast-+/fixnum
=>fixnum fast-safe-arith-op
)
238 (:args
(x :scs
(any-reg) :target r
239 :load-if
(not (and (sc-is x control-stack
)
241 (sc-is r control-stack
)
243 (y :scs
(any-reg control-stack
)))
244 (:arg-types tagged-num tagged-num
)
245 (:results
(r :scs
(any-reg) :from
(:argument
0)
246 :load-if
(not (and (sc-is x control-stack
)
248 (sc-is r control-stack
)
250 (:result-types tagged-num
)
251 (:note
"inline fixnum arithmetic")
253 (cond ((and (sc-is x any-reg
) (sc-is y any-reg
) (sc-is r any-reg
)
254 (not (location= x r
)))
255 (inst lea r
(make-ea :qword
:base x
:index y
:scale
1)))
260 (define-vop (fast-+-c
/fixnum
=>fixnum fast-safe-arith-op
)
262 (:args
(x :target r
:scs
(any-reg) :load-if t
))
264 (:arg-types tagged-num
(:constant fixnum
))
265 (:results
(r :scs
(any-reg) :load-if t
))
266 (:result-types tagged-num
)
267 (:note
"inline fixnum arithmetic")
269 (let ((y (fixnumize y
)))
270 (cond ((and (not (location= x r
))
271 (typep y
'(signed-byte 32)))
272 (inst lea r
(make-ea :qword
:base x
:disp y
)))
275 (inst add r
(constantize y
)))))))
277 (define-vop (fast-+/signed
=>signed fast-safe-arith-op
)
279 (:args
(x :scs
(signed-reg) :target r
280 :load-if
(not (and (sc-is x signed-stack
)
282 (sc-is r signed-stack
)
284 (y :scs
(signed-reg signed-stack
)))
285 (:arg-types signed-num signed-num
)
286 (:results
(r :scs
(signed-reg) :from
(:argument
0)
287 :load-if
(not (and (sc-is x signed-stack
)
290 (:result-types signed-num
)
291 (:note
"inline (signed-byte 64) arithmetic")
293 (cond ((and (sc-is x signed-reg
) (sc-is y signed-reg
) (sc-is r signed-reg
)
294 (not (location= x r
)))
295 (inst lea r
(make-ea :qword
:base x
:index y
:scale
1)))
300 ;;;; Special logand cases: (logand signed unsigned) => unsigned
302 (define-vop (fast-logand/signed-unsigned
=>unsigned
303 fast-logand
/unsigned
=>unsigned
)
304 (:args
(x :target r
:scs
(signed-reg)
305 :load-if
(not (and (sc-is x signed-stack
)
306 (sc-is y unsigned-reg
)
307 (sc-is r unsigned-stack
)
309 (y :scs
(unsigned-reg unsigned-stack
)))
310 (:arg-types signed-num unsigned-num
))
312 ;; This special case benefits from the special case for c/unsigned=>unsigned.
313 ;; In particular, converting a (signed-byte 64) to (unsigned-byte 64) by
314 ;; way of (LDB (byte 64 0)) doesn't need an AND instruction.
315 (define-vop (fast-logand-c/signed-unsigned
=>unsigned
316 fast-logand-c
/unsigned
=>unsigned
)
317 (:args
(x :target r
:scs
(signed-reg)))
318 (:arg-types signed-num
(:constant
(unsigned-byte 64))))
320 (define-vop (fast-logand/unsigned-signed
=>unsigned
321 fast-logand
/unsigned
=>unsigned
)
322 (:args
(x :target r
:scs
(unsigned-reg)
323 :load-if
(not (and (sc-is x unsigned-stack
)
325 (sc-is r unsigned-stack
)
327 (y :scs
(signed-reg signed-stack
)))
328 (:arg-types unsigned-num signed-num
))
331 (define-vop (fast-+-c
/signed
=>signed fast-safe-arith-op
)
333 (:args
(x :target r
:scs
(signed-reg)
334 :load-if
(or (not (typep y
'(signed-byte 32)))
335 (not (sc-is r signed-reg signed-stack
)))))
337 (:arg-types signed-num
(:constant
(signed-byte 64)))
338 (:results
(r :scs
(signed-reg)
339 :load-if
(or (not (location= x r
))
340 (not (typep y
'(signed-byte 32))))))
341 (:result-types signed-num
)
342 (:note
"inline (signed-byte 64) arithmetic")
344 (cond ((and (sc-is x signed-reg
) (sc-is r signed-reg
)
345 (not (location= x r
))
346 (typep y
'(signed-byte 32)))
347 (inst lea r
(make-ea :qword
:base x
:disp y
)))
353 (inst add r
(constantize y
))))))))
355 (define-vop (fast-+/unsigned
=>unsigned fast-safe-arith-op
)
357 (:args
(x :scs
(unsigned-reg) :target r
358 :load-if
(not (and (sc-is x unsigned-stack
)
359 (sc-is y unsigned-reg
)
360 (sc-is r unsigned-stack
)
362 (y :scs
(unsigned-reg unsigned-stack
)))
363 (:arg-types unsigned-num unsigned-num
)
364 (:results
(r :scs
(unsigned-reg) :from
(:argument
0)
365 :load-if
(not (and (sc-is x unsigned-stack
)
366 (sc-is y unsigned-reg
)
367 (sc-is r unsigned-stack
)
369 (:result-types unsigned-num
)
370 (:note
"inline (unsigned-byte 64) arithmetic")
372 (cond ((and (sc-is x unsigned-reg
) (sc-is y unsigned-reg
)
373 (sc-is r unsigned-reg
) (not (location= x r
)))
374 (inst lea r
(make-ea :qword
:base x
:index y
:scale
1)))
379 (define-vop (fast-+-c
/unsigned
=>unsigned fast-safe-arith-op
)
381 (:args
(x :target r
:scs
(unsigned-reg)
382 :load-if
(or (not (typep y
'(unsigned-byte 31)))
383 (not (sc-is x unsigned-reg unsigned-stack
)))))
385 (:arg-types unsigned-num
(:constant
(unsigned-byte 64)))
386 (:results
(r :scs
(unsigned-reg)
387 :load-if
(or (not (location= x r
))
388 (not (typep y
'(unsigned-byte 31))))))
389 (:result-types unsigned-num
)
390 (:note
"inline (unsigned-byte 64) arithmetic")
392 (cond ((and (sc-is x unsigned-reg
) (sc-is r unsigned-reg
)
393 (not (location= x r
))
394 (typep y
'(unsigned-byte 31)))
395 (inst lea r
(make-ea :qword
:base x
:disp y
)))
401 (inst add r
(constantize y
))))))))
403 ;;;; multiplication and division
405 (define-vop (fast-*/fixnum
=>fixnum fast-safe-arith-op
)
407 ;; We need different loading characteristics.
408 (:args
(x :scs
(any-reg) :target r
)
409 (y :scs
(any-reg control-stack
)))
410 (:arg-types tagged-num tagged-num
)
411 (:results
(r :scs
(any-reg) :from
(:argument
0)))
412 (:result-types tagged-num
)
413 (:note
"inline fixnum arithmetic")
416 (inst sar r n-fixnum-tag-bits
)
419 (define-vop (fast-*-c
/fixnum
=>fixnum fast-safe-arith-op
)
421 ;; We need different loading characteristics.
422 (:args
(x :scs
(any-reg)
423 :load-if
(or (not (typep y
'(signed-byte 32)))
424 (not (sc-is x any-reg control-stack
)))))
426 (:arg-types tagged-num
(:constant fixnum
))
427 (:results
(r :scs
(any-reg)))
428 (:result-types tagged-num
)
429 (:note
"inline fixnum arithmetic")
431 (cond ((typep y
'(signed-byte 32))
435 (inst imul r
(register-inline-constant :qword y
))))))
437 (define-vop (fast-*/signed
=>signed fast-safe-arith-op
)
439 ;; We need different loading characteristics.
440 (:args
(x :scs
(signed-reg) :target r
)
441 (y :scs
(signed-reg signed-stack
)))
442 (:arg-types signed-num signed-num
)
443 (:results
(r :scs
(signed-reg) :from
(:argument
0)))
444 (:result-types signed-num
)
445 (:note
"inline (signed-byte 64) arithmetic")
450 (define-vop (fast-*-c
/signed
=>signed fast-safe-arith-op
)
452 ;; We need different loading characteristics.
453 (:args
(x :scs
(signed-reg)
454 :load-if
(or (not (typep y
'(signed-byte 32)))
455 (not (sc-is x signed-reg signed-stack
)))))
457 (:arg-types signed-num
(:constant
(signed-byte 64)))
458 (:results
(r :scs
(signed-reg)))
459 (:result-types signed-num
)
460 (:note
"inline (signed-byte 64) arithmetic")
462 (cond ((typep y
'(signed-byte 32))
466 (inst imul r
(register-inline-constant :qword y
))))))
468 (define-vop (fast-*/unsigned
=>unsigned fast-safe-arith-op
)
470 (:args
(x :scs
(unsigned-reg) :target eax
)
471 (y :scs
(unsigned-reg unsigned-stack
)))
472 (:arg-types unsigned-num unsigned-num
)
473 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target r
474 :from
(:argument
0) :to
:result
) eax
)
475 (:temporary
(:sc unsigned-reg
:offset edx-offset
476 :from
:eval
:to
:result
) edx
)
478 (:results
(r :scs
(unsigned-reg)))
479 (:result-types unsigned-num
)
480 (:note
"inline (unsigned-byte 64) arithmetic")
482 (:save-p
:compute-only
)
488 (define-vop (fast-*-c
/unsigned
=>unsigned fast-safe-arith-op
)
490 (:args
(x :scs
(unsigned-reg) :target eax
))
492 (:arg-types unsigned-num
(:constant
(unsigned-byte 64)))
493 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target r
494 :from
(:argument
0) :to
:result
) eax
)
495 (:temporary
(:sc unsigned-reg
:offset edx-offset
496 :from
:eval
:to
:result
) edx
)
498 (:results
(r :scs
(unsigned-reg)))
499 (:result-types unsigned-num
)
500 (:note
"inline (unsigned-byte 64) arithmetic")
502 (:save-p
:compute-only
)
505 (inst mul eax
(register-inline-constant :qword y
))
509 (define-vop (fast-truncate/fixnum
=>fixnum fast-safe-arith-op
)
510 (:translate truncate
)
511 (:args
(x :scs
(any-reg) :target eax
)
512 (y :scs
(any-reg control-stack
)))
513 (:arg-types tagged-num tagged-num
)
514 (:temporary
(:sc signed-reg
:offset eax-offset
:target quo
515 :from
(:argument
0) :to
(:result
0)) eax
)
516 (:temporary
(:sc unsigned-reg
:offset edx-offset
:target rem
517 :from
(:argument
0) :to
(:result
1)) edx
)
518 (:results
(quo :scs
(any-reg))
519 (rem :scs
(any-reg)))
520 (:result-types tagged-num tagged-num
)
521 (:note
"inline fixnum arithmetic")
523 (:save-p
:compute-only
)
525 (let ((zero (generate-error-code vop
'division-by-zero-error x y
)))
526 (if (sc-is y any-reg
)
527 (inst test y y
) ; smaller instruction
533 (if (location= quo eax
)
534 (inst shl eax n-fixnum-tag-bits
)
535 (if (= n-fixnum-tag-bits
1)
536 (inst lea quo
(make-ea :qword
:base eax
:index eax
))
537 (inst lea quo
(make-ea :qword
:index eax
538 :scale
(ash 1 n-fixnum-tag-bits
)))))
541 (define-vop (fast-truncate-c/fixnum
=>fixnum fast-safe-arith-op
)
542 (:translate truncate
)
543 (:args
(x :scs
(any-reg) :target eax
))
545 (:arg-types tagged-num
(:constant fixnum
))
546 (:temporary
(:sc signed-reg
:offset eax-offset
:target quo
547 :from
:argument
:to
(:result
0)) eax
)
548 (:temporary
(:sc any-reg
:offset edx-offset
:target rem
549 :from
:eval
:to
(:result
1)) edx
)
550 (:temporary
(:sc any-reg
:from
:eval
:to
:result
) y-arg
)
551 (:results
(quo :scs
(any-reg))
552 (rem :scs
(any-reg)))
553 (:result-types tagged-num tagged-num
)
554 (:note
"inline fixnum arithmetic")
556 (:save-p
:compute-only
)
560 (inst mov y-arg
(fixnumize y
))
561 (inst idiv eax y-arg
)
562 (if (location= quo eax
)
563 (inst shl eax n-fixnum-tag-bits
)
564 (if (= n-fixnum-tag-bits
1)
565 (inst lea quo
(make-ea :qword
:base eax
:index eax
))
566 (inst lea quo
(make-ea :qword
:index eax
567 :scale
(ash 1 n-fixnum-tag-bits
)))))
570 (define-vop (fast-truncate/unsigned
=>unsigned fast-safe-arith-op
)
571 (:translate truncate
)
572 (:args
(x :scs
(unsigned-reg) :target eax
)
573 (y :scs
(unsigned-reg signed-stack
)))
574 (:arg-types unsigned-num unsigned-num
)
575 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target quo
576 :from
(:argument
0) :to
(:result
0)) eax
)
577 (:temporary
(:sc unsigned-reg
:offset edx-offset
:target rem
578 :from
(:argument
0) :to
(:result
1)) edx
)
579 (:results
(quo :scs
(unsigned-reg))
580 (rem :scs
(unsigned-reg)))
581 (:result-types unsigned-num unsigned-num
)
582 (:note
"inline (unsigned-byte 64) arithmetic")
584 (:save-p
:compute-only
)
586 (let ((zero (generate-error-code vop
'division-by-zero-error x y
)))
587 (if (sc-is y unsigned-reg
)
588 (inst test y y
) ; smaller instruction
597 (define-vop (fast-truncate-c/unsigned
=>unsigned fast-safe-arith-op
)
598 (:translate truncate
)
599 (:args
(x :scs
(unsigned-reg) :target eax
))
601 (:arg-types unsigned-num
(:constant
(unsigned-byte 64)))
602 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target quo
603 :from
:argument
:to
(:result
0)) eax
)
604 (:temporary
(:sc unsigned-reg
:offset edx-offset
:target rem
605 :from
:eval
:to
(:result
1)) edx
)
606 (:temporary
(:sc unsigned-reg
:from
:eval
:to
:result
) y-arg
)
607 (:results
(quo :scs
(unsigned-reg))
608 (rem :scs
(unsigned-reg)))
609 (:result-types unsigned-num unsigned-num
)
610 (:note
"inline (unsigned-byte 64) arithmetic")
612 (:save-p
:compute-only
)
621 (define-vop (fast-truncate/signed
=>signed fast-safe-arith-op
)
622 (:translate truncate
)
623 (:args
(x :scs
(signed-reg) :target eax
)
624 (y :scs
(signed-reg signed-stack
)))
625 (:arg-types signed-num signed-num
)
626 (:temporary
(:sc signed-reg
:offset eax-offset
:target quo
627 :from
(:argument
0) :to
(:result
0)) eax
)
628 (:temporary
(:sc signed-reg
:offset edx-offset
:target rem
629 :from
(:argument
0) :to
(:result
1)) edx
)
630 (:results
(quo :scs
(signed-reg))
631 (rem :scs
(signed-reg)))
632 (:result-types signed-num signed-num
)
633 (:note
"inline (signed-byte 64) arithmetic")
635 (:save-p
:compute-only
)
637 (let ((zero (generate-error-code vop
'division-by-zero-error x y
)))
638 (if (sc-is y signed-reg
)
639 (inst test y y
) ; smaller instruction
648 (define-vop (fast-truncate-c/signed
=>signed fast-safe-arith-op
)
649 (:translate truncate
)
650 (:args
(x :scs
(signed-reg) :target eax
))
652 (:arg-types signed-num
(:constant
(signed-byte 64)))
653 (:temporary
(:sc signed-reg
:offset eax-offset
:target quo
654 :from
:argument
:to
(:result
0)) eax
)
655 (:temporary
(:sc signed-reg
:offset edx-offset
:target rem
656 :from
:eval
:to
(:result
1)) edx
)
657 (:temporary
(:sc signed-reg
:from
:eval
:to
:result
) y-arg
)
658 (:results
(quo :scs
(signed-reg))
659 (rem :scs
(signed-reg)))
660 (:result-types signed-num signed-num
)
661 (:note
"inline (signed-byte 64) arithmetic")
663 (:save-p
:compute-only
)
668 (inst idiv eax y-arg
)
675 (define-vop (fast-ash-c/fixnum
=>fixnum
)
678 (:args
(number :scs
(any-reg) :target result
679 :load-if
(not (and (sc-is number any-reg control-stack
)
680 (sc-is result any-reg control-stack
)
681 (location= number result
)))))
683 (:arg-types tagged-num
(:constant integer
))
684 (:results
(result :scs
(any-reg)
685 :load-if
(not (and (sc-is number control-stack
)
686 (sc-is result control-stack
)
687 (location= number result
)))))
688 (:result-types tagged-num
)
691 (:variant-vars modularp
)
693 (cond ((and (= amount
1) (not (location= number result
)))
694 (inst lea result
(make-ea :qword
:base number
:index number
)))
695 ((and (= amount
2) (not (location= number result
)))
696 (inst lea result
(make-ea :qword
:index number
:scale
4)))
697 ((and (= amount
3) (not (location= number result
)))
698 (inst lea result
(make-ea :qword
:index number
:scale
8)))
701 (cond ((< -
64 amount
64)
702 ;; this code is used both in ASH and ASH-MODFX, so
705 (inst shl result amount
)
707 (inst sar result
(- amount
))
708 (inst and result
(lognot fixnum-tag-mask
)))))
709 ;; shifting left (zero fill)
712 (aver (not "Impossible: fixnum ASH should not be called with
713 constant shift greater than word length")))
714 (if (sc-is result any-reg
)
716 (inst mov result
0)))
717 ;; shifting right (sign fill)
718 (t (inst sar result
63)
719 (inst and result
(lognot fixnum-tag-mask
))))))))
721 (define-vop (fast-ash-left/fixnum
=>fixnum
)
723 (:args
(number :scs
(any-reg) :target result
724 :load-if
(not (and (sc-is number control-stack
)
725 (sc-is result control-stack
)
726 (location= number result
))))
727 (amount :scs
(unsigned-reg) :target ecx
))
728 (:arg-types tagged-num positive-fixnum
)
729 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
730 (:results
(result :scs
(any-reg) :from
(:argument
0)
731 :load-if
(not (and (sc-is number control-stack
)
732 (sc-is result control-stack
)
733 (location= number result
)))))
734 (:result-types tagged-num
)
740 ;; The result-type ensures us that this shift will not overflow.
741 (inst shl result
:cl
)))
743 (define-vop (fast-ash-c/signed
=>signed
)
746 (:args
(number :scs
(signed-reg) :target result
747 :load-if
(not (and (sc-is number signed-stack
)
748 (sc-is result signed-stack
)
749 (location= number result
)))))
751 (:arg-types signed-num
(:constant integer
))
752 (:results
(result :scs
(signed-reg)
753 :load-if
(not (and (sc-is number signed-stack
)
754 (sc-is result signed-stack
)
755 (location= number result
)))))
756 (:result-types signed-num
)
759 (cond ((and (= amount
1) (not (location= number result
)))
760 (inst lea result
(make-ea :qword
:base number
:index number
)))
761 ((and (= amount
2) (not (location= number result
)))
762 (inst lea result
(make-ea :qword
:index number
:scale
4)))
763 ((and (= amount
3) (not (location= number result
)))
764 (inst lea result
(make-ea :qword
:index number
:scale
8)))
767 (cond ((plusp amount
) (inst shl result amount
))
768 (t (inst sar result
(min 63 (- amount
)))))))))
770 (define-vop (fast-ash-c/unsigned
=>unsigned
)
773 (:args
(number :scs
(unsigned-reg) :target result
774 :load-if
(not (and (sc-is number unsigned-stack
)
775 (sc-is result unsigned-stack
)
776 (location= number result
)))))
778 (:arg-types unsigned-num
(:constant integer
))
779 (:results
(result :scs
(unsigned-reg)
780 :load-if
(not (and (sc-is number unsigned-stack
)
781 (sc-is result unsigned-stack
)
782 (location= number result
)))))
783 (:result-types unsigned-num
)
786 (cond ((and (= amount
1) (not (location= number result
)))
787 (inst lea result
(make-ea :qword
:base number
:index number
)))
788 ((and (= amount
2) (not (location= number result
)))
789 (inst lea result
(make-ea :qword
:index number
:scale
4)))
790 ((and (= amount
3) (not (location= number result
)))
791 (inst lea result
(make-ea :qword
:index number
:scale
8)))
794 (cond ((< -
64 amount
64) ;; XXXX
795 ;; this code is used both in ASH and ASH-MOD32, so
798 (inst shl result amount
)
799 (inst shr result
(- amount
))))
800 (t (if (sc-is result unsigned-reg
)
802 (inst mov result
0))))))))
804 (define-vop (fast-ash-left/signed
=>signed
)
806 (:args
(number :scs
(signed-reg) :target result
807 :load-if
(not (and (sc-is number signed-stack
)
808 (sc-is result signed-stack
)
809 (location= number result
))))
810 (amount :scs
(unsigned-reg) :target ecx
))
811 (:arg-types signed-num positive-fixnum
)
812 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
813 (:results
(result :scs
(signed-reg) :from
(:argument
0)
814 :load-if
(not (and (sc-is number signed-stack
)
815 (sc-is result signed-stack
)
816 (location= number result
)))))
817 (:result-types signed-num
)
823 (inst shl result
:cl
)))
825 (define-vop (fast-ash-left/unsigned
=>unsigned
)
827 (:args
(number :scs
(unsigned-reg) :target result
828 :load-if
(not (and (sc-is number unsigned-stack
)
829 (sc-is result unsigned-stack
)
830 (location= number result
))))
831 (amount :scs
(unsigned-reg) :target ecx
))
832 (:arg-types unsigned-num positive-fixnum
)
833 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
834 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)
835 :load-if
(not (and (sc-is number unsigned-stack
)
836 (sc-is result unsigned-stack
)
837 (location= number result
)))))
838 (:result-types unsigned-num
)
844 (inst shl result
:cl
)))
846 (define-vop (fast-ash/signed
=>signed
)
849 (:args
(number :scs
(signed-reg) :target result
)
850 (amount :scs
(signed-reg) :target ecx
))
851 (:arg-types signed-num signed-num
)
852 (:results
(result :scs
(signed-reg) :from
(:argument
0)))
853 (:result-types signed-num
)
854 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
860 (inst jmp
:ns POSITIVE
)
866 (inst sar result
:cl
)
870 ;; The result-type ensures us that this shift will not overflow.
871 (inst shl result
:cl
)
875 (define-vop (fast-ash/unsigned
=>unsigned
)
878 (:args
(number :scs
(unsigned-reg) :target result
)
879 (amount :scs
(signed-reg) :target ecx
))
880 (:arg-types unsigned-num signed-num
)
881 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)))
882 (:result-types unsigned-num
)
883 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
889 (inst jmp
:ns POSITIVE
)
896 (inst shr result
:cl
)
900 ;; The result-type ensures us that this shift will not overflow.
901 (inst shl result
:cl
)
906 (define-vop (fast-%ash
/right
/unsigned
)
907 (:translate %ash
/right
)
909 (:args
(number :scs
(unsigned-reg) :target result
)
910 (amount :scs
(unsigned-reg) :target rcx
))
911 (:arg-types unsigned-num unsigned-num
)
912 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)))
913 (:result-types unsigned-num
)
914 (:temporary
(:sc signed-reg
:offset rcx-offset
:from
(:argument
1)) rcx
)
918 (inst shr result
:cl
)))
921 (define-vop (fast-%ash
/right
/signed
)
922 (:translate %ash
/right
)
924 (:args
(number :scs
(signed-reg) :target result
)
925 (amount :scs
(unsigned-reg) :target rcx
))
926 (:arg-types signed-num unsigned-num
)
927 (:results
(result :scs
(signed-reg) :from
(:argument
0)))
928 (:result-types signed-num
)
929 (:temporary
(:sc signed-reg
:offset rcx-offset
:from
(:argument
1)) rcx
)
933 (inst sar result
:cl
)))
936 (define-vop (fast-%ash
/right
/fixnum
)
937 (:translate %ash
/right
)
939 (:args
(number :scs
(any-reg) :target result
)
940 (amount :scs
(unsigned-reg) :target rcx
))
941 (:arg-types tagged-num unsigned-num
)
942 (:results
(result :scs
(any-reg) :from
(:argument
0)))
943 (:result-types tagged-num
)
944 (:temporary
(:sc signed-reg
:offset rcx-offset
:from
(:argument
1)) rcx
)
948 (inst sar result
:cl
)
949 (inst and result
(lognot fixnum-tag-mask
))))
953 (defknown %lea
(integer integer
(member 1 2 4 8 16) (signed-byte 64))
955 (foldable flushable movable
))
957 (defoptimizer (%lea derive-type
) ((base index scale disp
))
958 (when (and (constant-lvar-p scale
)
959 (constant-lvar-p disp
))
960 (let ((scale (lvar-value scale
))
961 (disp (lvar-value disp
))
962 (base-type (lvar-type base
))
963 (index-type (lvar-type index
)))
964 (when (and (numeric-type-p base-type
)
965 (numeric-type-p index-type
))
966 (let ((base-lo (numeric-type-low base-type
))
967 (base-hi (numeric-type-high base-type
))
968 (index-lo (numeric-type-low index-type
))
969 (index-hi (numeric-type-high index-type
)))
970 (make-numeric-type :class
'integer
972 :low
(when (and base-lo index-lo
)
973 (+ base-lo
(* index-lo scale
) disp
))
974 :high
(when (and base-hi index-hi
)
975 (+ base-hi
(* index-hi scale
) disp
))))))))
977 (defun %lea
(base index scale disp
)
978 (+ base
(* index scale
) disp
))
982 (define-vop (%lea
/unsigned
=>unsigned
)
985 (:args
(base :scs
(unsigned-reg))
986 (index :scs
(unsigned-reg)))
988 (:arg-types unsigned-num unsigned-num
989 (:constant
(member 1 2 4 8))
990 (:constant
(signed-byte 64)))
991 (:results
(r :scs
(unsigned-reg)))
992 (:result-types unsigned-num
)
994 (inst lea r
(make-ea :qword
:base base
:index index
995 :scale scale
:disp disp
))))
997 (define-vop (%lea
/signed
=>signed
)
1000 (:args
(base :scs
(signed-reg))
1001 (index :scs
(signed-reg)))
1003 (:arg-types signed-num signed-num
1004 (:constant
(member 1 2 4 8))
1005 (:constant
(signed-byte 64)))
1006 (:results
(r :scs
(signed-reg)))
1007 (:result-types signed-num
)
1009 (inst lea r
(make-ea :qword
:base base
:index index
1010 :scale scale
:disp disp
))))
1012 (define-vop (%lea
/fixnum
=>fixnum
)
1014 (:policy
:fast-safe
)
1015 (:args
(base :scs
(any-reg))
1016 (index :scs
(any-reg)))
1018 (:arg-types tagged-num tagged-num
1019 (:constant
(member 1 2 4 8))
1020 (:constant
(signed-byte 64)))
1021 (:results
(r :scs
(any-reg)))
1022 (:result-types tagged-num
)
1024 (inst lea r
(make-ea :qword
:base base
:index index
1025 :scale scale
:disp disp
))))
1027 ;;; FIXME: before making knowledge of this too public, it needs to be
1028 ;;; fixed so that it's actually _faster_ than the non-CMOV version; at
1029 ;;; least on my Celeron-XXX laptop, this version is marginally slower
1030 ;;; than the above version with branches. -- CSR, 2003-09-04
1031 (define-vop (fast-cmov-ash/unsigned
=>unsigned
)
1033 (:policy
:fast-safe
)
1034 (:args
(number :scs
(unsigned-reg) :target result
)
1035 (amount :scs
(signed-reg) :target ecx
))
1036 (:arg-types unsigned-num signed-num
)
1037 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)))
1038 (:result-types unsigned-num
)
1039 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
1040 (:temporary
(:sc any-reg
:from
(:eval
0) :to
(:eval
1)) zero
)
1041 (:note
"inline ASH")
1042 (:guard
(member :cmov
*backend-subfeatures
*))
1044 (move result number
)
1047 (inst jmp
:ns POSITIVE
)
1050 (inst shr result
:cl
)
1052 (inst cmov
:nbe result zero
)
1056 ;; The result-type ensures us that this shift will not overflow.
1057 (inst shl result
:cl
)
1061 (define-vop (signed-byte-64-len)
1062 (:translate integer-length
)
1063 (:note
"inline (signed-byte 64) integer-length")
1064 (:policy
:fast-safe
)
1065 (:args
(arg :scs
(signed-reg) :target res
))
1066 (:arg-types signed-num
)
1067 (:results
(res :scs
(unsigned-reg)))
1068 (:result-types unsigned-num
)
1083 (define-vop (unsigned-byte-64-len)
1084 (:translate integer-length
)
1085 (:note
"inline (unsigned-byte 64) integer-length")
1086 (:policy
:fast-safe
)
1087 (:args
(arg :scs
(unsigned-reg)))
1088 (:arg-types unsigned-num
)
1089 (:results
(res :scs
(unsigned-reg)))
1090 (:result-types unsigned-num
)
1100 ;; INTEGER-LENGTH is implemented by using the BSR instruction, which
1101 ;; returns the position of the first 1-bit from the right. And that needs
1102 ;; to be incremented to get the width of the integer, and BSR doesn't
1103 ;; work on 0, so it needs a branch to handle 0.
1105 ;; But fixnums are tagged by being shifted left n-fixnum-tag-bits times,
1106 ;; untagging by shifting right n-fixnum-tag-bits-1 times (and if
1107 ;; n-fixnum-tag-bits = 1, no shifting is required), will make the
1108 ;; resulting integer one bit wider, making the increment unnecessary.
1109 ;; Then, to avoid calling BSR on 0, OR the result with 1. That sets the
1110 ;; first bit to 1, and if all other bits are 0, BSR will return 0,
1111 ;; which is the correct value for INTEGER-LENGTH.
1112 (define-vop (positive-fixnum-len)
1113 (:translate integer-length
)
1114 (:note
"inline positive fixnum integer-length")
1115 (:policy
:fast-safe
)
1116 (:args
(arg :scs
(any-reg)))
1117 (:arg-types positive-fixnum
)
1118 (:results
(res :scs
(unsigned-reg)))
1119 (:result-types unsigned-num
)
1122 (when (> n-fixnum-tag-bits
1)
1123 (inst shr res
(1- n-fixnum-tag-bits
)))
1125 (inst bsr res res
)))
1127 (define-vop (fixnum-len)
1128 (:translate integer-length
)
1129 (:note
"inline fixnum integer-length")
1130 (:policy
:fast-safe
)
1131 (:args
(arg :scs
(any-reg) :target res
))
1132 (:arg-types tagged-num
)
1133 (:results
(res :scs
(unsigned-reg)))
1134 (:result-types unsigned-num
)
1137 (when (> n-fixnum-tag-bits
1)
1138 (inst sar res
(1- n-fixnum-tag-bits
)))
1144 (inst bsr res res
)))
1146 (define-vop (unsigned-byte-64-count)
1147 (:translate logcount
)
1148 (:note
"inline (unsigned-byte 64) logcount")
1149 (:policy
:fast-safe
)
1150 (:args
(arg :scs
(unsigned-reg) :target result
))
1151 (:arg-types unsigned-num
)
1152 (:results
(result :scs
(unsigned-reg)))
1153 (:result-types positive-fixnum
)
1154 (:temporary
(:sc unsigned-reg
) temp
)
1155 (:temporary
(:sc unsigned-reg
) mask
)
1157 ;; See the comments below for how the algorithm works. The tricks
1158 ;; used can be found for example in AMD's software optimization
1159 ;; guide or at "http://www.hackersdelight.org/HDcode/pop.cc" in the
1160 ;; function "pop1", for 32-bit words. The extension to 64 bits is
1162 ;; Calculate 2-bit sums. Note that the value of a two-digit binary
1163 ;; number is the sum of the right digit and twice the left digit.
1164 ;; Thus we can calculate the sum of the two digits by shifting the
1165 ;; left digit to the right position and doing a two-bit subtraction.
1166 ;; This subtraction will never create a borrow and thus can be made
1167 ;; on all 32 2-digit numbers at once.
1171 (inst mov mask
#x5555555555555555
)
1172 (inst and result mask
)
1173 (inst sub temp result
)
1174 ;; Calculate 4-bit sums by straightforward shift, mask and add.
1175 ;; Note that we shift the source operand of the MOV and not its
1176 ;; destination so that the SHR and the MOV can execute in the same
1178 (inst mov result temp
)
1180 (inst mov mask
#x3333333333333333
)
1181 (inst and result mask
)
1182 (inst and temp mask
)
1183 (inst add result temp
)
1184 ;; Calculate 8-bit sums. Since each sum is at most 8, which fits
1185 ;; into 4 bits, we can apply the mask after the addition, saving one
1187 (inst mov temp result
)
1189 (inst add result temp
)
1190 (inst mov mask
#x0f0f0f0f0f0f0f0f
)
1191 (inst and result mask
)
1192 ;; Add all 8 bytes at once by multiplying with #256r11111111.
1193 ;; We need to calculate only the lower 8 bytes of the product.
1194 ;; Of these the most significant byte contains the final result.
1195 ;; Note that there can be no overflow from one byte to the next
1196 ;; as the sum is at most 64 which needs only 7 bits.
1197 (inst mov mask
#x0101010101010101
)
1198 (inst imul result mask
)
1199 (inst shr result
56)))
1201 ;;;; binary conditional VOPs
1203 (define-vop (fast-conditional)
1208 (:policy
:fast-safe
))
1210 (define-vop (fast-conditional/fixnum fast-conditional
)
1211 (:args
(x :scs
(any-reg)
1212 :load-if
(not (and (sc-is x control-stack
)
1213 (sc-is y any-reg
))))
1214 (y :scs
(any-reg control-stack
)))
1215 (:arg-types tagged-num tagged-num
)
1216 (:note
"inline fixnum comparison"))
1218 (define-vop (fast-conditional-c/fixnum fast-conditional
/fixnum
)
1219 (:args
(x :scs
(any-reg) :load-if t
))
1220 (:arg-types tagged-num
(:constant fixnum
))
1223 (define-vop (fast-conditional/signed fast-conditional
)
1224 (:args
(x :scs
(signed-reg)
1225 :load-if
(not (and (sc-is x signed-stack
)
1226 (sc-is y signed-reg
))))
1227 (y :scs
(signed-reg signed-stack
)))
1228 (:arg-types signed-num signed-num
)
1229 (:note
"inline (signed-byte 64) comparison"))
1231 (define-vop (fast-conditional-c/signed fast-conditional
/signed
)
1232 (:args
(x :scs
(signed-reg) :load-if t
))
1233 (:arg-types signed-num
(:constant
(signed-byte 64)))
1236 (define-vop (fast-conditional/unsigned fast-conditional
)
1237 (:args
(x :scs
(unsigned-reg)
1238 :load-if
(not (and (sc-is x unsigned-stack
)
1239 (sc-is y unsigned-reg
))))
1240 (y :scs
(unsigned-reg unsigned-stack
)))
1241 (:arg-types unsigned-num unsigned-num
)
1242 (:note
"inline (unsigned-byte 64) comparison"))
1244 (define-vop (fast-conditional-c/unsigned fast-conditional
/unsigned
)
1245 (:args
(x :scs
(unsigned-reg) :load-if t
))
1246 (:arg-types unsigned-num
(:constant
(unsigned-byte 64)))
1249 ;; Stolen liberally from the x86 32-bit implementation.
1250 (macrolet ((define-logtest-vops ()
1252 ,@(loop for suffix in
'(/fixnum -c
/fixnum
1254 /unsigned -c
/unsigned
)
1255 for cost in
'(4 3 6 5 6 5)
1257 `(define-vop (,(symbolicate "FAST-LOGTEST" suffix
)
1258 ,(symbolicate "FAST-CONDITIONAL" suffix
))
1259 (:translate logtest
)
1262 (emit-optimized-test-inst x
1265 `(constantize (fixnumize y
)))
1266 ((-c/signed -c
/unsigned
)
1270 (define-logtest-vops))
1272 (defknown %logbitp
(integer unsigned-byte
) boolean
1273 (movable foldable flushable always-translatable
))
1275 ;;; only for constant folding within the compiler
1276 (defun %logbitp
(integer index
)
1277 (logbitp index integer
))
1279 ;;; too much work to do the non-constant case (maybe?)
1280 (define-vop (fast-logbitp-c/fixnum fast-conditional-c
/fixnum
)
1281 (:translate %logbitp
)
1283 (:arg-types tagged-num
(:constant
(integer 0 #.
(- 63 n-fixnum-tag-bits
))))
1285 (inst bt x
(+ y n-fixnum-tag-bits
))))
1287 (define-vop (fast-logbitp/signed fast-conditional
/signed
)
1288 (:args
(x :scs
(signed-reg signed-stack
))
1289 (y :scs
(signed-reg)))
1290 (:translate %logbitp
)
1295 (define-vop (fast-logbitp-c/signed fast-conditional-c
/signed
)
1296 (:translate %logbitp
)
1298 (:arg-types signed-num
(:constant
(integer 0 63)))
1302 (define-vop (fast-logbitp/unsigned fast-conditional
/unsigned
)
1303 (:args
(x :scs
(unsigned-reg unsigned-stack
))
1304 (y :scs
(unsigned-reg)))
1305 (:translate %logbitp
)
1310 (define-vop (fast-logbitp-c/unsigned fast-conditional-c
/unsigned
)
1311 (:translate %logbitp
)
1313 (:arg-types unsigned-num
(:constant
(integer 0 63)))
1317 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned
)
1320 (lambda (suffix cost signed
)
1321 `(define-vop (;; FIXME: These could be done more
1322 ;; cleanly with SYMBOLICATE.
1323 ,(intern (format nil
"~:@(FAST-IF-~A~A~)"
1326 (format nil
"~:@(FAST-CONDITIONAL~A~)"
1329 (:conditional
,(if signed cond unsigned
))
1331 (cond ((and (sc-is x any-reg signed-reg unsigned-reg
)
1338 `(constantize (fixnumize y
)))
1339 ((-c/signed -c
/unsigned
)
1342 '(/fixnum -c
/fixnum
/signed -c
/signed
/unsigned -c
/unsigned
)
1343 ; '(/fixnum /signed /unsigned)
1345 '(t t t t nil nil
)))))
1347 (define-conditional-vop < :l
:b
:ge
:ae
)
1348 (define-conditional-vop > :g
:a
:le
:be
))
1350 (define-vop (fast-if-eql/signed fast-conditional
/signed
)
1355 (define-vop (fast-if-eql-c/signed fast-conditional-c
/signed
)
1358 (cond ((and (sc-is x signed-reg
) (zerop y
))
1359 (inst test x x
)) ; smaller instruction
1361 (inst cmp x
(constantize y
))))))
1363 (define-vop (fast-if-eql/unsigned fast-conditional
/unsigned
)
1368 (define-vop (fast-if-eql-c/unsigned fast-conditional-c
/unsigned
)
1371 (cond ((and (sc-is x unsigned-reg
) (zerop y
))
1372 (inst test x x
)) ; smaller instruction
1374 (inst cmp x
(constantize y
))))))
1376 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
1379 ;;; These versions specify a fixnum restriction on their first arg. We have
1380 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
1381 ;;; the first arg and a higher cost. The reason for doing this is to prevent
1382 ;;; fixnum specific operations from being used on word integers, spuriously
1383 ;;; consing the argument.
1385 (define-vop (fast-eql/fixnum fast-conditional
)
1386 (:args
(x :scs
(any-reg)
1387 :load-if
(not (and (sc-is x control-stack
)
1388 (sc-is y any-reg
))))
1389 (y :scs
(any-reg control-stack
)))
1390 (:arg-types tagged-num tagged-num
)
1391 (:note
"inline fixnum comparison")
1396 (define-vop (generic-eql/fixnum fast-eql
/fixnum
)
1397 (:args
(x :scs
(any-reg descriptor-reg
)
1398 :load-if
(not (and (sc-is x control-stack
)
1399 (sc-is y any-reg
))))
1400 (y :scs
(any-reg control-stack
)))
1401 (:arg-types
* tagged-num
)
1404 (define-vop (fast-eql-c/fixnum fast-conditional-c
/fixnum
)
1405 (:args
(x :scs
(any-reg) :load-if t
))
1406 (:arg-types tagged-num
(:constant fixnum
))
1409 (:policy
:fast-safe
)
1412 (cond ((and (sc-is x any-reg descriptor-reg
) (zerop y
))
1413 (inst test x x
)) ; smaller instruction
1415 (inst cmp x
(constantize (fixnumize y
)))))))
1417 (define-vop (generic-eql-c/fixnum fast-eql-c
/fixnum
)
1418 (:args
(x :scs
(any-reg descriptor-reg
) :load-if t
))
1419 (:arg-types
* (:constant fixnum
))
1422 ;;;; 32-bit logical operations
1424 ;;; Only the lower 6 bits of the shift amount are significant.
1425 (define-vop (shift-towards-someplace)
1426 (:policy
:fast-safe
)
1427 (:args
(num :scs
(unsigned-reg) :target r
)
1428 (amount :scs
(signed-reg) :target ecx
))
1429 (:arg-types unsigned-num tagged-num
)
1430 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
1431 (:results
(r :scs
(unsigned-reg) :from
(:argument
0)))
1432 (:result-types unsigned-num
))
1434 (define-vop (shift-towards-start shift-towards-someplace
)
1435 (:translate shift-towards-start
)
1436 (:note
"SHIFT-TOWARDS-START")
1442 (define-vop (shift-towards-end shift-towards-someplace
)
1443 (:translate shift-towards-end
)
1444 (:note
"SHIFT-TOWARDS-END")
1450 ;;;; Modular functions
1452 (defmacro define-mod-binop
((name prototype
) function
)
1453 `(define-vop (,name
,prototype
)
1454 (:args
(x :target r
:scs
(unsigned-reg signed-reg
)
1455 :load-if
(not (and (or (sc-is x unsigned-stack
)
1456 (sc-is x signed-stack
))
1457 (or (sc-is y unsigned-reg
)
1458 (sc-is y signed-reg
))
1459 (or (sc-is r unsigned-stack
)
1460 (sc-is r signed-stack
))
1462 (y :scs
(unsigned-reg signed-reg unsigned-stack signed-stack
)))
1463 (:arg-types untagged-num untagged-num
)
1464 (:results
(r :scs
(unsigned-reg signed-reg
) :from
(:argument
0)
1465 :load-if
(not (and (or (sc-is x unsigned-stack
)
1466 (sc-is x signed-stack
))
1467 (or (sc-is y unsigned-reg
)
1468 (sc-is y unsigned-reg
))
1469 (or (sc-is r unsigned-stack
)
1470 (sc-is r unsigned-stack
))
1472 (:result-types unsigned-num
)
1473 (:translate
,function
)))
1474 (defmacro define-mod-binop-c
((name prototype
) function
)
1475 `(define-vop (,name
,prototype
)
1476 (:args
(x :target r
:scs
(unsigned-reg signed-reg
)
1479 (:arg-types untagged-num
(:constant
(or (unsigned-byte 64) (signed-byte 64))))
1480 (:results
(r :scs
(unsigned-reg signed-reg
) :from
(:argument
0)
1482 (:result-types unsigned-num
)
1483 (:translate
,function
)))
1485 (macrolet ((def (name -c-p
)
1486 (let ((fun64 (intern (format nil
"~S-MOD64" name
)))
1487 (vopu (intern (format nil
"FAST-~S/UNSIGNED=>UNSIGNED" name
)))
1488 (vopcu (intern (format nil
"FAST-~S-C/UNSIGNED=>UNSIGNED" name
)))
1489 (vopf (intern (format nil
"FAST-~S/FIXNUM=>FIXNUM" name
)))
1490 (vopcf (intern (format nil
"FAST-~S-C/FIXNUM=>FIXNUM" name
)))
1491 (vop64u (intern (format nil
"FAST-~S-MOD64/WORD=>UNSIGNED" name
)))
1492 (vop64f (intern (format nil
"FAST-~S-MOD64/FIXNUM=>FIXNUM" name
)))
1493 (vop64cu (intern (format nil
"FAST-~S-MOD64-C/WORD=>UNSIGNED" name
)))
1494 (vop64cf (intern (format nil
"FAST-~S-MOD64-C/FIXNUM=>FIXNUM" name
)))
1495 (funfx (intern (format nil
"~S-MODFX" name
)))
1496 (vopfxf (intern (format nil
"FAST-~S-MODFX/FIXNUM=>FIXNUM" name
)))
1497 (vopfxcf (intern (format nil
"FAST-~S-MODFX-C/FIXNUM=>FIXNUM" name
))))
1499 (define-modular-fun ,fun64
(x y
) ,name
:untagged nil
64)
1500 (define-modular-fun ,funfx
(x y
) ,name
:tagged t
1501 #.
(- n-word-bits n-fixnum-tag-bits
))
1502 (define-mod-binop (,vop64u
,vopu
) ,fun64
)
1503 (define-vop (,vop64f
,vopf
) (:translate
,fun64
))
1504 (define-vop (,vopfxf
,vopf
) (:translate
,funfx
))
1506 `((define-mod-binop-c (,vop64cu
,vopcu
) ,fun64
)
1507 (define-vop (,vopfxcf
,vopcf
) (:translate
,funfx
))))))))
1512 (define-modular-fun %negate-mod64
(x) %negate
:untagged nil
64)
1513 (define-vop (%negate-mod64
)
1514 (:translate %negate-mod64
)
1515 (:policy
:fast-safe
)
1516 (:args
(x :scs
(unsigned-reg) :target r
))
1517 (:arg-types unsigned-num
)
1518 (:results
(r :scs
(unsigned-reg)))
1519 (:result-types unsigned-num
)
1524 (define-modular-fun %negate-modfx
(x) %negate
:tagged t
#.
(- n-word-bits
1526 (define-vop (%negate-modfx fast-negate
/fixnum
)
1527 (:translate %negate-modfx
))
1529 (define-vop (fast-ash-left-mod64-c/unsigned
=>unsigned
1530 fast-ash-c
/unsigned
=>unsigned
)
1531 (:translate ash-left-mod64
))
1532 (define-vop (fast-ash-left-mod64/unsigned
=>unsigned
1533 fast-ash-left
/unsigned
=>unsigned
))
1534 (deftransform ash-left-mod64
((integer count
)
1535 ((unsigned-byte 64) (unsigned-byte 6)))
1536 (when (sb!c
::constant-lvar-p count
)
1537 (sb!c
::give-up-ir1-transform
))
1538 '(%primitive fast-ash-left-mod64
/unsigned
=>unsigned integer count
))
1540 (define-vop (fast-ash-left-modfx-c/fixnum
=>fixnum
1541 fast-ash-c
/fixnum
=>fixnum
)
1543 (:translate ash-left-modfx
))
1544 (define-vop (fast-ash-left-modfx/fixnum
=>fixnum
1545 fast-ash-left
/fixnum
=>fixnum
))
1546 (deftransform ash-left-modfx
((integer count
)
1547 (fixnum (unsigned-byte 6)))
1548 (when (sb!c
::constant-lvar-p count
)
1549 (sb!c
::give-up-ir1-transform
))
1550 '(%primitive fast-ash-left-modfx
/fixnum
=>fixnum integer count
))
1554 (defknown sb
!vm
::%lea-mod64
(integer integer
(member 1 2 4 8) (signed-byte 64))
1556 (foldable flushable movable
))
1557 (defknown sb
!vm
::%lea-modfx
(integer integer
(member 1 2 4 8) (signed-byte 64))
1559 (foldable flushable movable
))
1561 (define-modular-fun-optimizer %lea
((base index scale disp
) :untagged nil
:width width
)
1562 (when (and (<= width
64)
1563 (constant-lvar-p scale
)
1564 (constant-lvar-p disp
))
1565 (cut-to-width base
:untagged width nil
)
1566 (cut-to-width index
:untagged width nil
)
1567 'sb
!vm
::%lea-mod64
))
1568 (define-modular-fun-optimizer %lea
((base index scale disp
) :tagged t
:width width
)
1569 (when (and (<= width
(- sb
!vm
:n-word-bits sb
!vm
:n-fixnum-tag-bits
))
1570 (constant-lvar-p scale
)
1571 (constant-lvar-p disp
))
1572 (cut-to-width base
:tagged width t
)
1573 (cut-to-width index
:tagged width t
)
1574 'sb
!vm
::%lea-modfx
))
1578 (defun sb!vm
::%lea-mod64
(base index scale disp
)
1579 (ldb (byte 64 0) (%lea base index scale disp
)))
1580 (defun sb!vm
::%lea-modfx
(base index scale disp
)
1581 (mask-signed-field (- sb
!vm
:n-word-bits sb
!vm
:n-fixnum-tag-bits
)
1582 (%lea base index scale disp
))))
1585 (defun sb!vm
::%lea-mod64
(base index scale disp
)
1586 (let ((base (logand base
#xffffffffffffffff
))
1587 (index (logand index
#xffffffffffffffff
)))
1588 ;; can't use modular version of %LEA, as we only have VOPs for
1589 ;; constant SCALE and DISP.
1590 (ldb (byte 64 0) (+ base
(* index scale
) disp
))))
1591 (defun sb!vm
::%lea-modfx
(base index scale disp
)
1592 (let* ((fixnum-width (- sb
!vm
:n-word-bits sb
!vm
:n-fixnum-tag-bits
))
1593 (base (mask-signed-field fixnum-width base
))
1594 (index (mask-signed-field fixnum-width index
)))
1595 ;; can't use modular version of %LEA, as we only have VOPs for
1596 ;; constant SCALE and DISP.
1597 (mask-signed-field fixnum-width
(+ base
(* index scale
) disp
)))))
1599 (in-package "SB!VM")
1601 (define-vop (%lea-mod64
/unsigned
=>unsigned
1602 %lea
/unsigned
=>unsigned
)
1603 (:translate %lea-mod64
))
1604 (define-vop (%lea-modfx
/fixnum
=>fixnum
1605 %lea
/fixnum
=>fixnum
)
1606 (:translate %lea-modfx
))
1608 ;;; logical operations
1609 (define-modular-fun lognot-mod64
(x) lognot
:untagged nil
64)
1610 (define-vop (lognot-mod64/unsigned
=>unsigned
)
1611 (:translate lognot-mod64
)
1612 (:args
(x :scs
(unsigned-reg unsigned-stack
) :target r
1613 :load-if
(not (and (sc-is x unsigned-stack
)
1614 (sc-is r unsigned-stack
)
1616 (:arg-types unsigned-num
)
1617 (:results
(r :scs
(unsigned-reg)
1618 :load-if
(not (and (sc-is x unsigned-stack
)
1619 (sc-is r unsigned-stack
)
1621 (:result-types unsigned-num
)
1622 (:policy
:fast-safe
)
1627 (define-source-transform logeqv
(&rest args
)
1628 (if (oddp (length args
))
1630 `(lognot (logxor ,@args
))))
1631 (define-source-transform logandc1
(x y
)
1632 `(logand (lognot ,x
) ,y
))
1633 (define-source-transform logandc2
(x y
)
1634 `(logand ,x
(lognot ,y
)))
1635 (define-source-transform logorc1
(x y
)
1636 `(logior (lognot ,x
) ,y
))
1637 (define-source-transform logorc2
(x y
)
1638 `(logior ,x
(lognot ,y
)))
1639 (define-source-transform lognor
(x y
)
1640 `(lognot (logior ,x
,y
)))
1641 (define-source-transform lognand
(x y
)
1642 `(lognot (logand ,x
,y
)))
1646 (define-vop (bignum-length get-header-data
)
1647 (:translate sb
!bignum
:%bignum-length
)
1648 (:policy
:fast-safe
))
1650 (define-vop (bignum-set-length set-header-data
)
1651 (:translate sb
!bignum
:%bignum-set-length
)
1652 (:policy
:fast-safe
))
1654 (define-full-reffer bignum-ref
* bignum-digits-offset other-pointer-lowtag
1655 (unsigned-reg) unsigned-num sb
!bignum
:%bignum-ref
)
1656 (define-full-reffer+offset bignum-ref-with-offset
* bignum-digits-offset
1657 other-pointer-lowtag
(unsigned-reg) unsigned-num
1658 sb
!bignum
:%bignum-ref-with-offset
)
1659 (define-full-setter bignum-set
* bignum-digits-offset other-pointer-lowtag
1660 (unsigned-reg) unsigned-num sb
!bignum
:%bignum-set
)
1662 (define-vop (digit-0-or-plus)
1663 (:translate sb
!bignum
:%digit-0-or-plusp
)
1664 (:policy
:fast-safe
)
1665 (:args
(digit :scs
(unsigned-reg)))
1666 (:arg-types unsigned-num
)
1669 (inst test digit digit
)))
1672 ;;; For add and sub with carry the sc of carry argument is any-reg so
1673 ;;; that it may be passed as a fixnum or word and thus may be 0, 1, or
1674 ;;; 8. This is easy to deal with and may save a fixnum-word
1676 (define-vop (add-w/carry
)
1677 (:translate sb
!bignum
:%add-with-carry
)
1678 (:policy
:fast-safe
)
1679 (:args
(a :scs
(unsigned-reg) :target result
)
1680 (b :scs
(unsigned-reg unsigned-stack
) :to
:eval
)
1681 (c :scs
(any-reg) :target temp
))
1682 (:arg-types unsigned-num unsigned-num positive-fixnum
)
1683 (:temporary
(:sc any-reg
:from
(:argument
2) :to
:eval
) temp
)
1684 (:results
(result :scs
(unsigned-reg) :from
(:argument
0))
1685 (carry :scs
(unsigned-reg)))
1686 (:result-types unsigned-num positive-fixnum
)
1690 (inst neg temp
) ; Set the carry flag to 0 if c=0 else to 1
1693 (inst adc carry carry
)))
1695 ;;; Note: the borrow is 1 for no borrow and 0 for a borrow, the opposite
1696 ;;; of the x86-64 convention.
1697 (define-vop (sub-w/borrow
)
1698 (:translate sb
!bignum
:%subtract-with-borrow
)
1699 (:policy
:fast-safe
)
1700 (:args
(a :scs
(unsigned-reg) :to
:eval
:target result
)
1701 (b :scs
(unsigned-reg unsigned-stack
) :to
:result
)
1702 (c :scs
(any-reg control-stack
)))
1703 (:arg-types unsigned-num unsigned-num positive-fixnum
)
1704 (:results
(result :scs
(unsigned-reg) :from
:eval
)
1705 (borrow :scs
(unsigned-reg)))
1706 (:result-types unsigned-num positive-fixnum
)
1708 (inst cmp c
1) ; Set the carry flag to 1 if c=0 else to 0
1712 (inst sbb borrow
0)))
1715 (define-vop (bignum-mult-and-add-3-arg)
1716 (:translate sb
!bignum
:%multiply-and-add
)
1717 (:policy
:fast-safe
)
1718 (:args
(x :scs
(unsigned-reg) :target eax
)
1719 (y :scs
(unsigned-reg unsigned-stack
))
1720 (carry-in :scs
(unsigned-reg unsigned-stack
)))
1721 (:arg-types unsigned-num unsigned-num unsigned-num
)
1722 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0)
1723 :to
(:result
1) :target lo
) eax
)
1724 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
1)
1725 :to
(:result
0) :target hi
) edx
)
1726 (:results
(hi :scs
(unsigned-reg))
1727 (lo :scs
(unsigned-reg)))
1728 (:result-types unsigned-num unsigned-num
)
1732 (inst add eax carry-in
)
1737 (define-vop (bignum-mult-and-add-4-arg)
1738 (:translate sb
!bignum
:%multiply-and-add
)
1739 (:policy
:fast-safe
)
1740 (:args
(x :scs
(unsigned-reg) :target eax
)
1741 (y :scs
(unsigned-reg unsigned-stack
))
1742 (prev :scs
(unsigned-reg unsigned-stack
))
1743 (carry-in :scs
(unsigned-reg unsigned-stack
)))
1744 (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num
)
1745 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0)
1746 :to
(:result
1) :target lo
) eax
)
1747 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
1)
1748 :to
(:result
0) :target hi
) edx
)
1749 (:results
(hi :scs
(unsigned-reg))
1750 (lo :scs
(unsigned-reg)))
1751 (:result-types unsigned-num unsigned-num
)
1757 (inst add eax carry-in
)
1763 (define-vop (bignum-mult)
1764 (:translate sb
!bignum
:%multiply
)
1765 (:policy
:fast-safe
)
1766 (:args
(x :scs
(unsigned-reg) :target eax
)
1767 (y :scs
(unsigned-reg unsigned-stack
)))
1768 (:arg-types unsigned-num unsigned-num
)
1769 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0)
1770 :to
(:result
1) :target lo
) eax
)
1771 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
1)
1772 :to
(:result
0) :target hi
) edx
)
1773 (:results
(hi :scs
(unsigned-reg))
1774 (lo :scs
(unsigned-reg)))
1775 (:result-types unsigned-num unsigned-num
)
1782 #!+multiply-high-vops
1784 (:translate sb
!kernel
:%multiply-high
)
1785 (:policy
:fast-safe
)
1786 (:args
(x :scs
(unsigned-reg) :target eax
)
1787 (y :scs
(unsigned-reg unsigned-stack
)))
1788 (:arg-types unsigned-num unsigned-num
)
1789 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0))
1791 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
1)
1792 :to
(:result
0) :target hi
) edx
)
1793 (:results
(hi :scs
(unsigned-reg)))
1794 (:result-types unsigned-num
)
1800 #!+multiply-high-vops
1801 (define-vop (mulhi/fx
)
1802 (:translate sb
!kernel
:%multiply-high
)
1803 (:policy
:fast-safe
)
1804 (:args
(x :scs
(any-reg) :target eax
)
1805 (y :scs
(unsigned-reg unsigned-stack
)))
1806 (:arg-types positive-fixnum unsigned-num
)
1807 (:temporary
(:sc any-reg
:offset eax-offset
:from
(:argument
0)) eax
)
1808 (:temporary
(:sc any-reg
:offset edx-offset
:from
(:argument
1)
1809 :to
(:result
0) :target hi
) edx
)
1810 (:results
(hi :scs
(any-reg)))
1811 (:result-types positive-fixnum
)
1816 (inst and hi
(lognot fixnum-tag-mask
))))
1818 (define-vop (bignum-lognot lognot-mod64
/unsigned
=>unsigned
)
1819 (:translate sb
!bignum
:%lognot
))
1821 (define-vop (fixnum-to-digit)
1822 (:translate sb
!bignum
:%fixnum-to-digit
)
1823 (:policy
:fast-safe
)
1824 (:args
(fixnum :scs
(any-reg control-stack
) :target digit
))
1825 (:arg-types tagged-num
)
1826 (:results
(digit :scs
(unsigned-reg)
1827 :load-if
(not (and (sc-is fixnum control-stack
)
1828 (sc-is digit unsigned-stack
)
1829 (location= fixnum digit
)))))
1830 (:result-types unsigned-num
)
1833 (inst sar digit n-fixnum-tag-bits
)))
1835 (define-vop (bignum-floor)
1836 (:translate sb
!bignum
:%bigfloor
)
1837 (:policy
:fast-safe
)
1838 (:args
(div-high :scs
(unsigned-reg) :target edx
)
1839 (div-low :scs
(unsigned-reg) :target eax
)
1840 (divisor :scs
(unsigned-reg unsigned-stack
)))
1841 (:arg-types unsigned-num unsigned-num unsigned-num
)
1842 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
1)
1843 :to
(:result
0) :target quo
) eax
)
1844 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
0)
1845 :to
(:result
1) :target rem
) edx
)
1846 (:results
(quo :scs
(unsigned-reg))
1847 (rem :scs
(unsigned-reg)))
1848 (:result-types unsigned-num unsigned-num
)
1852 (inst div eax divisor
)
1856 (define-vop (signify-digit)
1857 (:translate sb
!bignum
:%fixnum-digit-with-correct-sign
)
1858 (:policy
:fast-safe
)
1859 (:args
(digit :scs
(unsigned-reg unsigned-stack
) :target res
))
1860 (:arg-types unsigned-num
)
1861 (:results
(res :scs
(any-reg signed-reg
)
1862 :load-if
(not (and (sc-is digit unsigned-stack
)
1863 (sc-is res control-stack signed-stack
)
1864 (location= digit res
)))))
1865 (:result-types signed-num
)
1868 (when (sc-is res any-reg control-stack
)
1869 (inst shl res n-fixnum-tag-bits
))))
1871 (define-vop (digit-ashr)
1872 (:translate sb
!bignum
:%ashr
)
1873 (:policy
:fast-safe
)
1874 (:args
(digit :scs
(unsigned-reg unsigned-stack
) :target result
)
1875 (count :scs
(unsigned-reg) :target ecx
))
1876 (:arg-types unsigned-num positive-fixnum
)
1877 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
1878 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)
1879 :load-if
(not (and (sc-is result unsigned-stack
)
1880 (location= digit result
)))))
1881 (:result-types unsigned-num
)
1885 (inst sar result
:cl
)))
1887 (define-vop (digit-ashr/c
)
1888 (:translate sb
!bignum
:%ashr
)
1889 (:policy
:fast-safe
)
1890 (:args
(digit :scs
(unsigned-reg unsigned-stack
) :target result
))
1891 (:arg-types unsigned-num
(:constant
(integer 0 63)))
1893 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)
1894 :load-if
(not (and (sc-is result unsigned-stack
)
1895 (location= digit result
)))))
1896 (:result-types unsigned-num
)
1899 (inst sar result count
)))
1901 (define-vop (digit-lshr digit-ashr
)
1902 (:translate sb
!bignum
:%digit-logical-shift-right
)
1906 (inst shr result
:cl
)))
1908 (define-vop (digit-ashl digit-ashr
)
1909 (:translate sb
!bignum
:%ashl
)
1913 (inst shl result
:cl
)))
1915 (define-vop (logand-bignum/c
)
1917 (:policy
:fast-safe
)
1918 (:args
(x :scs
(descriptor-reg)))
1919 (:arg-types bignum
(:constant word
))
1920 (:results
(r :scs
(unsigned-reg)))
1922 (:result-types unsigned-num
)
1924 (let ((mask (constantize mask
)))
1925 (cond ((or (integerp mask
)
1927 (loadw r x bignum-digits-offset other-pointer-lowtag
)
1928 (unless (eql mask -
1)
1932 (inst and r
(make-ea-for-object-slot x
1933 bignum-digits-offset
1934 other-pointer-lowtag
)))))))
1936 ;; Specialised mask-signed-field VOPs.
1937 (define-vop (mask-signed-field-word/c
)
1938 (:translate sb
!c
::mask-signed-field
)
1939 (:policy
:fast-safe
)
1940 (:args
(x :scs
(signed-reg unsigned-reg
) :target r
))
1941 (:arg-types
(:constant
(integer 0 64)) untagged-num
)
1942 (:results
(r :scs
(signed-reg)))
1943 (:result-types signed-num
)
1946 (cond ((zerop width
)
1950 ((member width
'(32 16 8))
1951 (inst movsx r
(reg-in-size x
(ecase width
1957 (let ((delta (- n-word-bits width
)))
1959 (inst sar r delta
))))))
1961 (define-vop (mask-signed-field-bignum/c
)
1962 (:translate sb
!c
::mask-signed-field
)
1963 (:policy
:fast-safe
)
1964 (:args
(x :scs
(descriptor-reg) :target r
))
1965 (:arg-types
(:constant
(integer 0 64)) bignum
)
1966 (:results
(r :scs
(signed-reg)))
1967 (:result-types signed-num
)
1970 (cond ((zerop width
)
1972 ((member width
'(8 16 32 64))
1974 (64 (loadw r x bignum-digits-offset other-pointer-lowtag
))
1976 (inst movsx r
(make-ea (ecase width
(32 :dword
) (16 :word
) (8 :byte
))
1978 :disp
(- (* bignum-digits-offset n-word-bytes
)
1979 other-pointer-lowtag
))))))
1981 (loadw r x bignum-digits-offset other-pointer-lowtag
)
1982 (let ((delta (- n-word-bits width
)))
1984 (inst sar r delta
))))))
1986 ;;;; static functions
1988 (define-static-fun two-arg-
/ (x y
) :translate
/)
1990 (define-static-fun two-arg-gcd
(x y
) :translate gcd
)
1991 (define-static-fun two-arg-lcm
(x y
) :translate lcm
)
1993 (define-static-fun two-arg-and
(x y
) :translate logand
)
1994 (define-static-fun two-arg-ior
(x y
) :translate logior
)
1995 (define-static-fun two-arg-xor
(x y
) :translate logxor
)
2000 (defun *-transformer
(y)
2002 ((= y
(ash 1 (integer-length y
)))
2003 ;; there's a generic transform for y = 2^k
2004 (give-up-ir1-transform))
2005 ((member y
'(3 5 9))
2006 ;; we can do these multiplications directly using LEA
2007 `(%lea x x
,(1- y
) 0))
2009 ;; A normal 64-bit multiplication takes 4 cycles on Athlon 64/Opteron.
2010 ;; Optimizing multiplications (other than the above cases) to
2011 ;; shifts/adds/leas gives a maximum improvement of 1 cycle, but requires
2012 ;; quite a lot of hairy code.
2013 (give-up-ir1-transform))))
2015 (deftransform * ((x y
)
2016 ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
2018 "recode as leas, shifts and adds"
2019 (let ((y (lvar-value y
)))
2021 (deftransform sb
!vm
::*-mod64
2022 ((x y
) ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
2024 "recode as leas, shifts and adds"
2025 (let ((y (lvar-value y
)))
2028 (deftransform * ((x y
)
2029 (fixnum (constant-arg (unsigned-byte 64)))
2031 "recode as leas, shifts and adds"
2032 (let ((y (lvar-value y
)))
2034 (deftransform sb
!vm
::*-modfx
2035 ((x y
) (fixnum (constant-arg (unsigned-byte 64)))
2037 "recode as leas, shifts and adds"
2038 (let ((y (lvar-value y
)))