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)
21 ((integer #.
(- (expt 2 64) (expt 2 31)) #.most-positive-word
)
22 (sb!c
::mask-signed-field
32 x
))
25 ;; If 'immediate32-p' is true, use it; otherwise use a RIP-relative constant.
26 ;; I couldn't think of a more accurate name for this other than maybe
27 ;; 'signed-immediate32-or-rip-relativize' which is just too awful.
28 (defun constantize (x)
30 (register-inline-constant :qword x
)))
34 (define-vop (fast-safe-arith-op)
39 (define-vop (fixnum-unop fast-safe-arith-op
)
40 (:args
(x :scs
(any-reg) :target res
))
41 (:results
(res :scs
(any-reg)))
42 (:note
"inline fixnum arithmetic")
43 (:arg-types tagged-num
)
44 (:result-types tagged-num
))
46 (define-vop (signed-unop fast-safe-arith-op
)
47 (:args
(x :scs
(signed-reg) :target res
))
48 (:results
(res :scs
(signed-reg)))
49 (:note
"inline (signed-byte 64) arithmetic")
50 (:arg-types signed-num
)
51 (:result-types signed-num
))
53 (define-vop (fast-negate/fixnum fixnum-unop
)
59 (define-vop (fast-negate/signed signed-unop
)
65 (define-vop (fast-negate/unsigned signed-unop
)
66 (:args
(x :scs
(unsigned-reg) :target res
))
67 (:arg-types unsigned-num
)
73 (define-vop (fast-negate/signed-unsigned signed-unop
)
74 (:results
(res :scs
(unsigned-reg)))
75 (:result-types unsigned-num
)
81 (define-vop (fast-lognot/fixnum fixnum-unop
)
85 (inst xor res
(fixnumize -
1))))
87 (define-vop (fast-lognot/signed signed-unop
)
93 ;;;; binary fixnum operations
95 ;;; Assume that any constant operand is the second arg...
97 (define-vop (fast-fixnum-binop fast-safe-arith-op
)
98 (:args
(x :target r
:scs
(any-reg)
99 :load-if
(not (and (sc-is x control-stack
)
101 (sc-is r control-stack
)
103 (y :scs
(any-reg control-stack
)))
104 (:arg-types tagged-num tagged-num
)
105 (:results
(r :scs
(any-reg) :from
(:argument
0)
106 :load-if
(not (and (sc-is x control-stack
)
108 (sc-is r control-stack
)
110 (:result-types tagged-num
)
111 (:note
"inline fixnum arithmetic"))
113 (define-vop (fast-unsigned-binop fast-safe-arith-op
)
114 (:args
(x :target r
:scs
(unsigned-reg)
115 :load-if
(not (and (sc-is x unsigned-stack
)
116 (sc-is y unsigned-reg
)
117 (sc-is r unsigned-stack
)
119 (y :scs
(unsigned-reg unsigned-stack
)))
120 (:arg-types unsigned-num unsigned-num
)
121 (:results
(r :scs
(unsigned-reg) :from
(:argument
0)
122 :load-if
(not (and (sc-is x unsigned-stack
)
123 (sc-is y unsigned-reg
)
124 (sc-is r unsigned-stack
)
126 (:result-types unsigned-num
)
127 (:note
"inline (unsigned-byte 64) arithmetic"))
129 (define-vop (fast-signed-binop fast-safe-arith-op
)
130 (:args
(x :target r
:scs
(signed-reg)
131 :load-if
(not (and (sc-is x signed-stack
)
133 (sc-is r signed-stack
)
135 (y :scs
(signed-reg signed-stack
)))
136 (:arg-types signed-num signed-num
)
137 (:results
(r :scs
(signed-reg) :from
(:argument
0)
138 :load-if
(not (and (sc-is x signed-stack
)
140 (sc-is r signed-stack
)
142 (:result-types signed-num
)
143 (:note
"inline (signed-byte 64) arithmetic"))
145 (define-vop (fast-fixnum-binop-c fast-safe-arith-op
)
146 (:args
(x :target r
:scs
(any-reg) :load-if t
))
148 (:arg-types tagged-num
(:constant fixnum
))
149 (:results
(r :scs
(any-reg) :load-if t
))
150 (:result-types tagged-num
)
151 (:note
"inline fixnum arithmetic"))
153 (define-vop (fast-unsigned-binop-c fast-safe-arith-op
)
154 (:args
(x :target r
:scs
(unsigned-reg) :load-if t
))
156 (:arg-types unsigned-num
(:constant
(unsigned-byte 64)))
157 (:results
(r :scs
(unsigned-reg) :load-if t
))
158 (:result-types unsigned-num
)
159 (:note
"inline (unsigned-byte 64) arithmetic"))
161 (define-vop (fast-signed-binop-c fast-safe-arith-op
)
162 (:args
(x :target r
:scs
(signed-reg) :load-if t
))
164 (:arg-types signed-num
(:constant
(signed-byte 64)))
165 (:results
(r :scs
(signed-reg) :load-if t
))
166 (:result-types signed-num
)
167 (:note
"inline (signed-byte 64) arithmetic"))
169 (macrolet ((define-binop (translate untagged-penalty op
170 &key fixnum
=>fixnum c
/fixnum
=>fixnum
171 signed
=>signed c
/signed
=>signed
172 unsigned
=>unsigned c
/unsigned
=>unsigned
)
175 (define-vop (,(symbolicate "FAST-" translate
"/FIXNUM=>FIXNUM")
177 (:translate
,translate
)
179 ,@(or fixnum
=>fixnum
`((move r x
) (inst ,op r y
)))))
180 (define-vop (,(symbolicate 'fast- translate
'-c
/fixnum
=>fixnum
)
182 (:translate
,translate
)
184 ,@(or c
/fixnum
=>fixnum
186 (inst ,op r
(constantize (fixnumize y
)))))))
187 (define-vop (,(symbolicate "FAST-" translate
"/SIGNED=>SIGNED")
189 (:translate
,translate
)
190 (:generator
,(1+ untagged-penalty
)
191 ,@(or signed
=>signed
`((move r x
) (inst ,op r y
)))))
192 (define-vop (,(symbolicate 'fast- translate
'-c
/signed
=>signed
)
194 (:translate
,translate
)
195 (:generator
,untagged-penalty
196 ,@(or c
/signed
=>signed
197 `((move r x
) (inst ,op r
(constantize y
))))))
198 (define-vop (,(symbolicate "FAST-"
200 "/UNSIGNED=>UNSIGNED")
202 (:translate
,translate
)
203 (:generator
,(1+ untagged-penalty
)
204 ,@(or unsigned
=>unsigned
`((move r x
) (inst ,op r y
)))))
205 (define-vop (,(symbolicate 'fast-
207 '-c
/unsigned
=>unsigned
)
208 fast-unsigned-binop-c
)
209 (:translate
,translate
)
210 (:generator
,untagged-penalty
211 ,@(or c
/unsigned
=>unsigned
212 `((move r x
) (inst ,op r
(constantize y
)))))))))
214 ;;(define-binop + 4 add)
215 (define-binop -
4 sub
)
217 ;; The following have microoptimizations for some special cases
218 ;; not caught by the front end.
220 (define-binop logand
2 and
221 :c
/unsigned
=>unsigned
223 (let ((y (constantize y
)))
224 ;; ANDing with #xFFFF_FFFF_FFFF_FFFF is a no-op, other than
225 ;; the eflags state which we don't care about.
226 (unless (eql y -
1) ; do nothing if this is true
229 (define-binop logior
2 or
230 :c
/unsigned
=>unsigned
231 ((let ((y (constantize y
)))
232 (cond ((and (register-p r
) (eql y -
1)) ; special-case "OR reg, all-ones"
233 ;; I have yet to elicit this case. Can it happen?
239 (define-binop logxor
2 xor
240 :c
/unsigned
=>unsigned
242 (let ((y (constantize y
)))
243 (if (eql y -
1) ; special-case "XOR reg, [all-ones]"
247 (define-vop (fast-logior-unsigned-signed=>signed fast-safe-arith-op
)
248 (:args
(x :scs
(unsigned-reg))
249 (y :target r
:scs
(signed-reg)))
250 (:arg-types unsigned-num signed-num
)
251 (:results
(r :scs
(signed-reg) :from
(:argument
1)))
252 (:result-types signed-num
)
253 (:note
"inline (unsigned-byte 64) arithmetic")
259 (define-vop (fast-logior-signed-unsigned=>signed fast-safe-arith-op
)
260 (:args
(x :target r
:scs
(signed-reg))
261 (y :scs
(unsigned-reg)))
262 (:arg-types signed-num unsigned-num
)
263 (:results
(r :scs
(signed-reg) :from
(:argument
0)))
264 (:result-types signed-num
)
265 (:note
"inline (unsigned-byte 64) arithmetic")
271 ;;; Special handling of add on the x86; can use lea to avoid a
272 ;;; register load, otherwise it uses add.
273 ;;; FIXME: either inherit from fast-foo-binop or explain why not.
274 (define-vop (fast-+/fixnum
=>fixnum fast-safe-arith-op
)
276 (:args
(x :scs
(any-reg) :target r
277 :load-if
(not (and (sc-is x control-stack
)
279 (sc-is r control-stack
)
281 (y :scs
(any-reg control-stack
)))
282 (:arg-types tagged-num tagged-num
)
283 (:results
(r :scs
(any-reg) :from
(:argument
0)
284 :load-if
(not (and (sc-is x control-stack
)
286 (sc-is r control-stack
)
288 (:result-types tagged-num
)
289 (:note
"inline fixnum arithmetic")
291 (cond ((and (sc-is x any-reg
) (sc-is y any-reg
) (sc-is r any-reg
)
292 (not (location= x r
)))
293 (inst lea r
(make-ea :qword
:base x
:index y
:scale
1)))
298 (define-vop (fast-+-c
/fixnum
=>fixnum fast-safe-arith-op
)
300 (:args
(x :target r
:scs
(any-reg) :load-if t
))
302 (:arg-types tagged-num
(:constant fixnum
))
303 (:results
(r :scs
(any-reg) :load-if t
))
304 (:result-types tagged-num
)
305 (:note
"inline fixnum arithmetic")
307 (let ((y (fixnumize y
)))
308 (cond ((and (not (location= x r
))
309 (typep y
'(signed-byte 32)))
310 (inst lea r
(make-ea :qword
:base x
:disp y
)))
313 (inst add r
(constantize y
)))))))
315 (define-vop (fast-+/signed
=>signed fast-safe-arith-op
)
317 (:args
(x :scs
(signed-reg) :target r
318 :load-if
(not (and (sc-is x signed-stack
)
320 (sc-is r signed-stack
)
322 (y :scs
(signed-reg signed-stack
)))
323 (:arg-types signed-num signed-num
)
324 (:results
(r :scs
(signed-reg) :from
(:argument
0)
325 :load-if
(not (and (sc-is x signed-stack
)
328 (:result-types signed-num
)
329 (:note
"inline (signed-byte 64) arithmetic")
331 (cond ((and (sc-is x signed-reg
) (sc-is y signed-reg
) (sc-is r signed-reg
)
332 (not (location= x r
)))
333 (inst lea r
(make-ea :qword
:base x
:index y
:scale
1)))
338 ;;;; Special logand cases: (logand signed unsigned) => unsigned
340 (define-vop (fast-logand/signed-unsigned
=>unsigned
341 fast-logand
/unsigned
=>unsigned
)
342 (:args
(x :target r
:scs
(signed-reg)
343 :load-if
(not (and (sc-is x signed-stack
)
344 (sc-is y unsigned-reg
)
345 (sc-is r unsigned-stack
)
347 (y :scs
(unsigned-reg unsigned-stack
)))
348 (:arg-types signed-num unsigned-num
))
350 ;; This special case benefits from the special case for c/unsigned=>unsigned.
351 ;; In particular, converting a (signed-byte 64) to (unsigned-byte 64) by
352 ;; way of (LDB (byte 64 0)) doesn't need an AND instruction.
353 (define-vop (fast-logand-c/signed-unsigned
=>unsigned
354 fast-logand-c
/unsigned
=>unsigned
)
355 (:args
(x :target r
:scs
(signed-reg)))
356 (:arg-types signed-num
(:constant
(unsigned-byte 64))))
358 (define-vop (fast-logand/unsigned-signed
=>unsigned
359 fast-logand
/unsigned
=>unsigned
)
360 (:args
(x :target r
:scs
(unsigned-reg)
361 :load-if
(not (and (sc-is x unsigned-stack
)
363 (sc-is r unsigned-stack
)
365 (y :scs
(signed-reg signed-stack
)))
366 (:arg-types unsigned-num signed-num
))
369 (define-vop (fast-+-c
/signed
=>signed fast-safe-arith-op
)
371 (:args
(x :target r
:scs
(signed-reg)
372 :load-if
(or (not (typep y
'(signed-byte 32)))
373 (not (sc-is r signed-reg signed-stack
)))))
375 (:arg-types signed-num
(:constant
(signed-byte 64)))
376 (:results
(r :scs
(signed-reg)
377 :load-if
(or (not (location= x r
))
378 (not (typep y
'(signed-byte 32))))))
379 (:result-types signed-num
)
380 (:note
"inline (signed-byte 64) arithmetic")
382 (cond ((and (sc-is x signed-reg
) (sc-is r signed-reg
)
383 (not (location= x r
))
384 (typep y
'(signed-byte 32)))
385 (inst lea r
(make-ea :qword
:base x
:disp y
)))
391 (inst add r
(constantize y
))))))))
393 (define-vop (fast-+/unsigned
=>unsigned fast-safe-arith-op
)
395 (:args
(x :scs
(unsigned-reg) :target r
396 :load-if
(not (and (sc-is x unsigned-stack
)
397 (sc-is y unsigned-reg
)
398 (sc-is r unsigned-stack
)
400 (y :scs
(unsigned-reg unsigned-stack
)))
401 (:arg-types unsigned-num unsigned-num
)
402 (:results
(r :scs
(unsigned-reg) :from
(:argument
0)
403 :load-if
(not (and (sc-is x unsigned-stack
)
404 (sc-is y unsigned-reg
)
405 (sc-is r unsigned-stack
)
407 (:result-types unsigned-num
)
408 (:note
"inline (unsigned-byte 64) arithmetic")
410 (cond ((and (sc-is x unsigned-reg
) (sc-is y unsigned-reg
)
411 (sc-is r unsigned-reg
) (not (location= x r
)))
412 (inst lea r
(make-ea :qword
:base x
:index y
:scale
1)))
417 (define-vop (fast-+-c
/unsigned
=>unsigned fast-safe-arith-op
)
419 (:args
(x :target r
:scs
(unsigned-reg)
420 :load-if
(or (not (typep y
'(unsigned-byte 31)))
421 (not (sc-is x unsigned-reg unsigned-stack
)))))
423 (:arg-types unsigned-num
(:constant
(unsigned-byte 64)))
424 (:results
(r :scs
(unsigned-reg)
425 :load-if
(or (not (location= x r
))
426 (not (typep y
'(unsigned-byte 31))))))
427 (:result-types unsigned-num
)
428 (:note
"inline (unsigned-byte 64) arithmetic")
430 (cond ((and (sc-is x unsigned-reg
) (sc-is r unsigned-reg
)
431 (not (location= x r
))
432 (typep y
'(unsigned-byte 31)))
433 (inst lea r
(make-ea :qword
:base x
:disp y
)))
439 (inst add r
(constantize y
))))))))
441 ;;;; multiplication and division
443 (define-vop (fast-*/fixnum
=>fixnum fast-safe-arith-op
)
445 ;; We need different loading characteristics.
446 (:args
(x :scs
(any-reg) :target r
)
447 (y :scs
(any-reg control-stack
)))
448 (:arg-types tagged-num tagged-num
)
449 (:results
(r :scs
(any-reg) :from
(:argument
0)))
450 (:result-types tagged-num
)
451 (:note
"inline fixnum arithmetic")
454 (inst sar r n-fixnum-tag-bits
)
457 (define-vop (fast-*-c
/fixnum
=>fixnum fast-safe-arith-op
)
459 ;; We need different loading characteristics.
460 (:args
(x :scs
(any-reg)
461 :load-if
(or (not (typep y
'(signed-byte 32)))
462 (not (sc-is x any-reg control-stack
)))))
464 (:arg-types tagged-num
(:constant fixnum
))
465 (:results
(r :scs
(any-reg)))
466 (:result-types tagged-num
)
467 (:note
"inline fixnum arithmetic")
469 (cond ((typep y
'(signed-byte 32))
473 (inst imul r
(register-inline-constant :qword y
))))))
475 (define-vop (fast-*/signed
=>signed fast-safe-arith-op
)
477 ;; We need different loading characteristics.
478 (:args
(x :scs
(signed-reg) :target r
)
479 (y :scs
(signed-reg signed-stack
)))
480 (:arg-types signed-num signed-num
)
481 (:results
(r :scs
(signed-reg) :from
(:argument
0)))
482 (:result-types signed-num
)
483 (:note
"inline (signed-byte 64) arithmetic")
488 (define-vop (fast-*-c
/signed
=>signed fast-safe-arith-op
)
490 ;; We need different loading characteristics.
491 (:args
(x :scs
(signed-reg)
492 :load-if
(or (not (typep y
'(signed-byte 32)))
493 (not (sc-is x signed-reg signed-stack
)))))
495 (:arg-types signed-num
(:constant
(signed-byte 64)))
496 (:results
(r :scs
(signed-reg)))
497 (:result-types signed-num
)
498 (:note
"inline (signed-byte 64) arithmetic")
500 (cond ((typep y
'(signed-byte 32))
504 (inst imul r
(register-inline-constant :qword y
))))))
506 (define-vop (fast-*/unsigned
=>unsigned fast-safe-arith-op
)
508 (:args
(x :scs
(unsigned-reg) :target eax
)
509 (y :scs
(unsigned-reg unsigned-stack
)))
510 (:arg-types unsigned-num unsigned-num
)
511 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target r
512 :from
(:argument
0) :to
:result
) eax
)
513 (:temporary
(:sc unsigned-reg
:offset edx-offset
514 :from
:eval
:to
:result
) edx
)
516 (:results
(r :scs
(unsigned-reg)))
517 (:result-types unsigned-num
)
518 (:note
"inline (unsigned-byte 64) arithmetic")
520 (:save-p
:compute-only
)
526 (define-vop (fast-*-c
/unsigned
=>unsigned fast-safe-arith-op
)
528 (:args
(x :scs
(unsigned-reg) :target eax
))
530 (:arg-types unsigned-num
(:constant
(unsigned-byte 64)))
531 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target r
532 :from
(:argument
0) :to
:result
) eax
)
533 (:temporary
(:sc unsigned-reg
:offset edx-offset
534 :from
:eval
:to
:result
) edx
)
536 (:results
(r :scs
(unsigned-reg)))
537 (:result-types unsigned-num
)
538 (:note
"inline (unsigned-byte 64) arithmetic")
540 (:save-p
:compute-only
)
543 (inst mul eax
(register-inline-constant :qword y
))
547 (define-vop (fast-truncate/fixnum
=>fixnum fast-safe-arith-op
)
548 (:translate truncate
)
549 (:args
(x :scs
(any-reg) :target eax
)
550 (y :scs
(any-reg control-stack
)))
551 (:arg-types tagged-num tagged-num
)
552 (:temporary
(:sc signed-reg
:offset eax-offset
:target quo
553 :from
(:argument
0) :to
(:result
0)) eax
)
554 (:temporary
(:sc unsigned-reg
:offset edx-offset
:target rem
555 :from
(:argument
0) :to
(:result
1)) edx
)
556 (:results
(quo :scs
(any-reg))
557 (rem :scs
(any-reg)))
558 (:result-types tagged-num tagged-num
)
559 (:note
"inline fixnum arithmetic")
561 (:save-p
:compute-only
)
563 (let ((zero (generate-error-code vop
'division-by-zero-error x y
)))
564 (if (sc-is y any-reg
)
565 (inst test y y
) ; smaller instruction
571 (if (location= quo eax
)
572 (inst shl eax n-fixnum-tag-bits
)
573 (if (= n-fixnum-tag-bits
1)
574 (inst lea quo
(make-ea :qword
:base eax
:index eax
))
575 (inst lea quo
(make-ea :qword
:index eax
576 :scale
(ash 1 n-fixnum-tag-bits
)))))
579 (define-vop (fast-truncate-c/fixnum
=>fixnum fast-safe-arith-op
)
580 (:translate truncate
)
581 (:args
(x :scs
(any-reg) :target eax
))
583 (:arg-types tagged-num
(:constant fixnum
))
584 (:temporary
(:sc signed-reg
:offset eax-offset
:target quo
585 :from
:argument
:to
(:result
0)) eax
)
586 (:temporary
(:sc any-reg
:offset edx-offset
:target rem
587 :from
:eval
:to
(:result
1)) edx
)
588 (:temporary
(:sc any-reg
:from
:eval
:to
:result
) y-arg
)
589 (:results
(quo :scs
(any-reg))
590 (rem :scs
(any-reg)))
591 (:result-types tagged-num tagged-num
)
592 (:note
"inline fixnum arithmetic")
594 (:save-p
:compute-only
)
598 (inst mov y-arg
(fixnumize y
))
599 (inst idiv eax y-arg
)
600 (if (location= quo eax
)
601 (inst shl eax n-fixnum-tag-bits
)
602 (if (= n-fixnum-tag-bits
1)
603 (inst lea quo
(make-ea :qword
:base eax
:index eax
))
604 (inst lea quo
(make-ea :qword
:index eax
605 :scale
(ash 1 n-fixnum-tag-bits
)))))
608 (define-vop (fast-truncate/unsigned
=>unsigned fast-safe-arith-op
)
609 (:translate truncate
)
610 (:args
(x :scs
(unsigned-reg) :target eax
)
611 (y :scs
(unsigned-reg signed-stack
)))
612 (:arg-types unsigned-num unsigned-num
)
613 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target quo
614 :from
(:argument
0) :to
(:result
0)) eax
)
615 (:temporary
(:sc unsigned-reg
:offset edx-offset
:target rem
616 :from
(:argument
0) :to
(:result
1)) edx
)
617 (:results
(quo :scs
(unsigned-reg))
618 (rem :scs
(unsigned-reg)))
619 (:result-types unsigned-num unsigned-num
)
620 (:note
"inline (unsigned-byte 64) arithmetic")
622 (:save-p
:compute-only
)
624 (let ((zero (generate-error-code vop
'division-by-zero-error x y
)))
625 (if (sc-is y unsigned-reg
)
626 (inst test y y
) ; smaller instruction
635 (define-vop (fast-truncate-c/unsigned
=>unsigned fast-safe-arith-op
)
636 (:translate truncate
)
637 (:args
(x :scs
(unsigned-reg) :target eax
))
639 (:arg-types unsigned-num
(:constant
(unsigned-byte 64)))
640 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target quo
641 :from
:argument
:to
(:result
0)) eax
)
642 (:temporary
(:sc unsigned-reg
:offset edx-offset
:target rem
643 :from
:eval
:to
(:result
1)) edx
)
644 (:temporary
(:sc unsigned-reg
:from
:eval
:to
:result
) y-arg
)
645 (:results
(quo :scs
(unsigned-reg))
646 (rem :scs
(unsigned-reg)))
647 (:result-types unsigned-num unsigned-num
)
648 (:note
"inline (unsigned-byte 64) arithmetic")
650 (:save-p
:compute-only
)
659 (define-vop (fast-truncate/signed
=>signed fast-safe-arith-op
)
660 (:translate truncate
)
661 (:args
(x :scs
(signed-reg) :target eax
)
662 (y :scs
(signed-reg signed-stack
)))
663 (:arg-types signed-num signed-num
)
664 (:temporary
(:sc signed-reg
:offset eax-offset
:target quo
665 :from
(:argument
0) :to
(:result
0)) eax
)
666 (:temporary
(:sc signed-reg
:offset edx-offset
:target rem
667 :from
(:argument
0) :to
(:result
1)) edx
)
668 (:results
(quo :scs
(signed-reg))
669 (rem :scs
(signed-reg)))
670 (:result-types signed-num signed-num
)
671 (:note
"inline (signed-byte 64) arithmetic")
673 (:save-p
:compute-only
)
675 (let ((zero (generate-error-code vop
'division-by-zero-error x y
)))
676 (if (sc-is y signed-reg
)
677 (inst test y y
) ; smaller instruction
686 (define-vop (fast-truncate-c/signed
=>signed fast-safe-arith-op
)
687 (:translate truncate
)
688 (:args
(x :scs
(signed-reg) :target eax
))
690 (:arg-types signed-num
(:constant
(signed-byte 64)))
691 (:temporary
(:sc signed-reg
:offset eax-offset
:target quo
692 :from
:argument
:to
(:result
0)) eax
)
693 (:temporary
(:sc signed-reg
:offset edx-offset
:target rem
694 :from
:eval
:to
(:result
1)) edx
)
695 (:temporary
(:sc signed-reg
:from
:eval
:to
:result
) y-arg
)
696 (:results
(quo :scs
(signed-reg))
697 (rem :scs
(signed-reg)))
698 (:result-types signed-num signed-num
)
699 (:note
"inline (signed-byte 64) arithmetic")
701 (:save-p
:compute-only
)
706 (inst idiv eax y-arg
)
713 (define-vop (fast-ash-c/fixnum
=>fixnum
)
716 (:args
(number :scs
(any-reg) :target result
717 :load-if
(not (and (sc-is number any-reg control-stack
)
718 (sc-is result any-reg control-stack
)
719 (location= number result
)))))
721 (:arg-types tagged-num
(:constant integer
))
722 (:results
(result :scs
(any-reg)
723 :load-if
(not (and (sc-is number control-stack
)
724 (sc-is result control-stack
)
725 (location= number result
)))))
726 (:result-types tagged-num
)
729 (:variant-vars modularp
)
731 (cond ((and (= amount
1) (not (location= number result
)))
732 (inst lea result
(make-ea :qword
:base number
:index number
)))
733 ((and (= amount
2) (not (location= number result
)))
734 (inst lea result
(make-ea :qword
:index number
:scale
4)))
735 ((and (= amount
3) (not (location= number result
)))
736 (inst lea result
(make-ea :qword
:index number
:scale
8)))
739 (cond ((< -
64 amount
64)
740 ;; this code is used both in ASH and ASH-MODFX, so
743 (inst shl result amount
)
745 (inst sar result
(- amount
))
746 (inst and result
(lognot fixnum-tag-mask
)))))
747 ;; shifting left (zero fill)
750 (aver (not "Impossible: fixnum ASH should not be called with
751 constant shift greater than word length")))
752 (if (sc-is result any-reg
)
754 (inst mov result
0)))
755 ;; shifting right (sign fill)
756 (t (inst sar result
63)
757 (inst and result
(lognot fixnum-tag-mask
))))))))
759 (define-vop (fast-ash-left/fixnum
=>fixnum
)
761 (:args
(number :scs
(any-reg) :target result
762 :load-if
(not (and (sc-is number control-stack
)
763 (sc-is result control-stack
)
764 (location= number result
))))
765 (amount :scs
(unsigned-reg) :target ecx
))
766 (:arg-types tagged-num positive-fixnum
)
767 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
768 (:results
(result :scs
(any-reg) :from
(:argument
0)
769 :load-if
(not (and (sc-is number control-stack
)
770 (sc-is result control-stack
)
771 (location= number result
)))))
772 (:result-types tagged-num
)
778 ;; The result-type ensures us that this shift will not overflow.
779 (inst shl result
:cl
)))
781 (define-vop (fast-ash-c/signed
=>signed
)
784 (:args
(number :scs
(signed-reg) :target result
785 :load-if
(not (and (sc-is number signed-stack
)
786 (sc-is result signed-stack
)
787 (location= number result
)))))
789 (:arg-types signed-num
(:constant integer
))
790 (:results
(result :scs
(signed-reg)
791 :load-if
(not (and (sc-is number signed-stack
)
792 (sc-is result signed-stack
)
793 (location= number result
)))))
794 (:result-types signed-num
)
797 (cond ((and (= amount
1) (not (location= number result
)))
798 (inst lea result
(make-ea :qword
:base number
:index number
)))
799 ((and (= amount
2) (not (location= number result
)))
800 (inst lea result
(make-ea :qword
:index number
:scale
4)))
801 ((and (= amount
3) (not (location= number result
)))
802 (inst lea result
(make-ea :qword
:index number
:scale
8)))
805 (cond ((plusp amount
) (inst shl result amount
))
806 (t (inst sar result
(min 63 (- amount
)))))))))
808 (define-vop (fast-ash-c/unsigned
=>unsigned
)
811 (:args
(number :scs
(unsigned-reg) :target result
812 :load-if
(not (and (sc-is number unsigned-stack
)
813 (sc-is result unsigned-stack
)
814 (location= number result
)))))
816 (:arg-types unsigned-num
(:constant integer
))
817 (:results
(result :scs
(unsigned-reg)
818 :load-if
(not (and (sc-is number unsigned-stack
)
819 (sc-is result unsigned-stack
)
820 (location= number result
)))))
821 (:result-types unsigned-num
)
824 (cond ((and (= amount
1) (not (location= number result
)))
825 (inst lea result
(make-ea :qword
:base number
:index number
)))
826 ((and (= amount
2) (not (location= number result
)))
827 (inst lea result
(make-ea :qword
:index number
:scale
4)))
828 ((and (= amount
3) (not (location= number result
)))
829 (inst lea result
(make-ea :qword
:index number
:scale
8)))
832 (cond ((< -
64 amount
64) ;; XXXX
833 ;; this code is used both in ASH and ASH-MOD64, so
836 (inst shl result amount
)
837 (inst shr result
(- amount
))))
838 (t (if (sc-is result unsigned-reg
)
840 (inst mov result
0))))))))
842 (define-vop (fast-ash-left/signed
=>signed
)
844 (:args
(number :scs
(signed-reg) :target result
845 :load-if
(not (and (sc-is number signed-stack
)
846 (sc-is result signed-stack
)
847 (location= number result
))))
848 (amount :scs
(unsigned-reg) :target ecx
))
849 (:arg-types signed-num positive-fixnum
)
850 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
851 (:results
(result :scs
(signed-reg) :from
(:argument
0)
852 :load-if
(not (and (sc-is number signed-stack
)
853 (sc-is result signed-stack
)
854 (location= number result
)))))
855 (:result-types signed-num
)
861 (inst shl result
:cl
)))
863 (define-vop (fast-ash-left/unsigned
=>unsigned
)
865 (:args
(number :scs
(unsigned-reg) :target result
866 :load-if
(not (and (sc-is number unsigned-stack
)
867 (sc-is result unsigned-stack
)
868 (location= number result
))))
869 (amount :scs
(unsigned-reg) :target ecx
))
870 (:arg-types unsigned-num positive-fixnum
)
871 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
872 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)
873 :load-if
(not (and (sc-is number unsigned-stack
)
874 (sc-is result unsigned-stack
)
875 (location= number result
)))))
876 (:result-types unsigned-num
)
882 (inst shl result
:cl
)))
884 (define-vop (fast-ash/signed
=>signed
)
887 (:args
(number :scs
(signed-reg) :target result
)
888 (amount :scs
(signed-reg) :target ecx
))
889 (:arg-types signed-num signed-num
)
890 (:results
(result :scs
(signed-reg) :from
(:argument
0)))
891 (:result-types signed-num
)
892 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
898 (inst jmp
:ns POSITIVE
)
904 (inst sar result
:cl
)
908 ;; The result-type ensures us that this shift will not overflow.
909 (inst shl result
:cl
)
913 (define-vop (fast-ash/unsigned
=>unsigned
)
916 (:args
(number :scs
(unsigned-reg) :target result
)
917 (amount :scs
(signed-reg) :target ecx
))
918 (:arg-types unsigned-num signed-num
)
919 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)))
920 (:result-types unsigned-num
)
921 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
927 (inst jmp
:ns POSITIVE
)
934 (inst shr result
:cl
)
938 ;; The result-type ensures us that this shift will not overflow.
939 (inst shl result
:cl
)
944 (define-vop (fast-%ash
/right
/unsigned
)
945 (:translate %ash
/right
)
947 (:args
(number :scs
(unsigned-reg) :target result
)
948 (amount :scs
(unsigned-reg) :target rcx
))
949 (:arg-types unsigned-num unsigned-num
)
950 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)))
951 (:result-types unsigned-num
)
952 (:temporary
(:sc signed-reg
:offset rcx-offset
:from
(:argument
1)) rcx
)
956 (inst shr result
:cl
)))
959 (define-vop (fast-%ash
/right
/signed
)
960 (:translate %ash
/right
)
962 (:args
(number :scs
(signed-reg) :target result
)
963 (amount :scs
(unsigned-reg) :target rcx
))
964 (:arg-types signed-num unsigned-num
)
965 (:results
(result :scs
(signed-reg) :from
(:argument
0)))
966 (:result-types signed-num
)
967 (:temporary
(:sc signed-reg
:offset rcx-offset
:from
(:argument
1)) rcx
)
971 (inst sar result
:cl
)))
974 (define-vop (fast-%ash
/right
/fixnum
)
975 (:translate %ash
/right
)
977 (:args
(number :scs
(any-reg) :target result
)
978 (amount :scs
(unsigned-reg) :target rcx
))
979 (:arg-types tagged-num unsigned-num
)
980 (:results
(result :scs
(any-reg) :from
(:argument
0)))
981 (:result-types tagged-num
)
982 (:temporary
(:sc signed-reg
:offset rcx-offset
:from
(:argument
1)) rcx
)
986 (inst sar result
:cl
)
987 (inst and result
(lognot fixnum-tag-mask
))))
991 (defknown %lea
(integer integer
(member 1 2 4 8 16) (signed-byte 64))
993 (foldable flushable movable
))
995 (defoptimizer (%lea derive-type
) ((base index scale disp
))
996 (when (and (constant-lvar-p scale
)
997 (constant-lvar-p disp
))
998 (let ((scale (lvar-value scale
))
999 (disp (lvar-value disp
))
1000 (base-type (lvar-type base
))
1001 (index-type (lvar-type index
)))
1002 (when (and (numeric-type-p base-type
)
1003 (numeric-type-p index-type
))
1004 (let ((base-lo (numeric-type-low base-type
))
1005 (base-hi (numeric-type-high base-type
))
1006 (index-lo (numeric-type-low index-type
))
1007 (index-hi (numeric-type-high index-type
)))
1008 (make-numeric-type :class
'integer
1010 :low
(when (and base-lo index-lo
)
1011 (+ base-lo
(* index-lo scale
) disp
))
1012 :high
(when (and base-hi index-hi
)
1013 (+ base-hi
(* index-hi scale
) disp
))))))))
1015 (defun %lea
(base index scale disp
)
1016 (+ base
(* index scale
) disp
))
1018 (in-package "SB!VM")
1020 (define-vop (%lea
/unsigned
=>unsigned
)
1022 (:policy
:fast-safe
)
1023 (:args
(base :scs
(unsigned-reg))
1024 (index :scs
(unsigned-reg)))
1026 (:arg-types unsigned-num unsigned-num
1027 (:constant
(member 1 2 4 8))
1028 (:constant
(signed-byte 64)))
1029 (:results
(r :scs
(unsigned-reg)))
1030 (:result-types unsigned-num
)
1032 (inst lea r
(make-ea :qword
:base base
:index index
1033 :scale scale
:disp disp
))))
1035 (define-vop (%lea
/signed
=>signed
)
1037 (:policy
:fast-safe
)
1038 (:args
(base :scs
(signed-reg))
1039 (index :scs
(signed-reg)))
1041 (:arg-types signed-num signed-num
1042 (:constant
(member 1 2 4 8))
1043 (:constant
(signed-byte 64)))
1044 (:results
(r :scs
(signed-reg)))
1045 (:result-types signed-num
)
1047 (inst lea r
(make-ea :qword
:base base
:index index
1048 :scale scale
:disp disp
))))
1050 (define-vop (%lea
/fixnum
=>fixnum
)
1052 (:policy
:fast-safe
)
1053 (:args
(base :scs
(any-reg))
1054 (index :scs
(any-reg)))
1056 (:arg-types tagged-num tagged-num
1057 (:constant
(member 1 2 4 8))
1058 (:constant
(signed-byte 64)))
1059 (:results
(r :scs
(any-reg)))
1060 (:result-types tagged-num
)
1062 (inst lea r
(make-ea :qword
:base base
:index index
1063 :scale scale
:disp disp
))))
1065 ;;; FIXME: before making knowledge of this too public, it needs to be
1066 ;;; fixed so that it's actually _faster_ than the non-CMOV version; at
1067 ;;; least on my Celeron-XXX laptop, this version is marginally slower
1068 ;;; than the above version with branches. -- CSR, 2003-09-04
1069 (define-vop (fast-cmov-ash/unsigned
=>unsigned
)
1071 (:policy
:fast-safe
)
1072 (:args
(number :scs
(unsigned-reg) :target result
)
1073 (amount :scs
(signed-reg) :target ecx
))
1074 (:arg-types unsigned-num signed-num
)
1075 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)))
1076 (:result-types unsigned-num
)
1077 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
1078 (:temporary
(:sc any-reg
:from
(:eval
0) :to
(:eval
1)) zero
)
1079 (:note
"inline ASH")
1080 (:guard
(member :cmov
*backend-subfeatures
*))
1082 (move result number
)
1085 (inst jmp
:ns POSITIVE
)
1088 (inst shr result
:cl
)
1090 (inst cmov
:nbe result zero
)
1094 ;; The result-type ensures us that this shift will not overflow.
1095 (inst shl result
:cl
)
1099 (define-vop (signed-byte-64-len)
1100 (:translate integer-length
)
1101 (:note
"inline (signed-byte 64) integer-length")
1102 (:policy
:fast-safe
)
1103 (:args
(arg :scs
(signed-reg) :target res
))
1104 (:arg-types signed-num
)
1105 (:results
(res :scs
(unsigned-reg)))
1106 (:result-types unsigned-num
)
1121 (define-vop (unsigned-byte-64-len)
1122 (:translate integer-length
)
1123 (:note
"inline (unsigned-byte 64) integer-length")
1124 (:policy
:fast-safe
)
1125 (:args
(arg :scs
(unsigned-reg)))
1126 (:arg-types unsigned-num
)
1127 (:results
(res :scs
(unsigned-reg)))
1128 (:result-types unsigned-num
)
1138 ;; The code on which this was based existed in no less than three varieties,
1139 ;; differing in response to 0 input: produce NIL, -1, or signal an error.
1140 ;; To avoid a thorny issue of proper semantics, this VOP is used only by
1141 ;; %BIT-POSITION which happens to declare zero safety, but always pre-checks
1142 ;; for zero. (the ltn-policy of :fast is actually irrelevant)
1143 (define-vop (unsigned-word-find-first-bit)
1145 (:args
(arg :scs
(unsigned-reg)))
1146 (:arg-types unsigned-num
)
1147 (:results
(res :scs
(unsigned-reg)))
1148 (:result-types unsigned-num
)
1150 (inst bsf res arg
)))
1152 ;; INTEGER-LENGTH is implemented by using the BSR instruction, which
1153 ;; returns the position of the first 1-bit from the right. And that needs
1154 ;; to be incremented to get the width of the integer, and BSR doesn't
1155 ;; work on 0, so it needs a branch to handle 0.
1157 ;; But fixnums are tagged by being shifted left n-fixnum-tag-bits times,
1158 ;; untagging by shifting right n-fixnum-tag-bits-1 times (and if
1159 ;; n-fixnum-tag-bits = 1, no shifting is required), will make the
1160 ;; resulting integer one bit wider, making the increment unnecessary.
1161 ;; Then, to avoid calling BSR on 0, OR the result with 1. That sets the
1162 ;; first bit to 1, and if all other bits are 0, BSR will return 0,
1163 ;; which is the correct value for INTEGER-LENGTH.
1164 (define-vop (positive-fixnum-len)
1165 (:translate integer-length
)
1166 (:note
"inline positive fixnum integer-length")
1167 (:policy
:fast-safe
)
1168 (:args
(arg :scs
(any-reg)))
1169 (:arg-types positive-fixnum
)
1170 (:results
(res :scs
(unsigned-reg)))
1171 (:result-types unsigned-num
)
1174 (when (> n-fixnum-tag-bits
1)
1175 (inst shr res
(1- n-fixnum-tag-bits
)))
1177 (inst bsr res res
)))
1179 (define-vop (fixnum-len)
1180 (:translate integer-length
)
1181 (:note
"inline fixnum integer-length")
1182 (:policy
:fast-safe
)
1183 (:args
(arg :scs
(any-reg) :target res
))
1184 (:arg-types tagged-num
)
1185 (:results
(res :scs
(unsigned-reg)))
1186 (:result-types unsigned-num
)
1189 (when (> n-fixnum-tag-bits
1)
1190 (inst sar res
(1- n-fixnum-tag-bits
)))
1196 (inst bsr res res
)))
1198 ;;;; binary conditional VOPs
1200 (define-vop (fast-conditional)
1205 (:policy
:fast-safe
))
1207 (define-vop (fast-conditional/fixnum fast-conditional
)
1208 (:args
(x :scs
(any-reg)
1209 :load-if
(not (and (sc-is x control-stack
)
1210 (sc-is y any-reg
))))
1211 (y :scs
(any-reg control-stack
)))
1212 (:arg-types tagged-num tagged-num
)
1213 (:note
"inline fixnum comparison"))
1215 (define-vop (fast-conditional-c/fixnum fast-conditional
/fixnum
)
1216 (:args
(x :scs
(any-reg) :load-if t
))
1217 (:arg-types tagged-num
(:constant fixnum
))
1220 (define-vop (fast-conditional/signed fast-conditional
)
1221 (:args
(x :scs
(signed-reg)
1222 :load-if
(not (and (sc-is x signed-stack
)
1223 (sc-is y signed-reg
))))
1224 (y :scs
(signed-reg signed-stack
)))
1225 (:arg-types signed-num signed-num
)
1226 (:note
"inline (signed-byte 64) comparison"))
1228 (define-vop (fast-conditional-c/signed fast-conditional
/signed
)
1229 (:args
(x :scs
(signed-reg) :load-if t
))
1230 (:arg-types signed-num
(:constant
(signed-byte 64)))
1233 (define-vop (fast-conditional/unsigned fast-conditional
)
1234 (:args
(x :scs
(unsigned-reg)
1235 :load-if
(not (and (sc-is x unsigned-stack
)
1236 (sc-is y unsigned-reg
))))
1237 (y :scs
(unsigned-reg unsigned-stack
)))
1238 (:arg-types unsigned-num unsigned-num
)
1239 (:note
"inline (unsigned-byte 64) comparison"))
1241 (define-vop (fast-conditional-c/unsigned fast-conditional
/unsigned
)
1242 (:args
(x :scs
(unsigned-reg) :load-if t
))
1243 (:arg-types unsigned-num
(:constant
(unsigned-byte 64)))
1246 ;; Stolen liberally from the x86 32-bit implementation.
1247 (macrolet ((define-logtest-vops ()
1249 ,@(loop for suffix in
'(/fixnum -c
/fixnum
1251 /unsigned -c
/unsigned
)
1252 for cost in
'(4 3 6 5 6 5)
1254 `(define-vop (,(symbolicate "FAST-LOGTEST" suffix
)
1255 ,(symbolicate "FAST-CONDITIONAL" suffix
))
1256 (:translate logtest
)
1259 (emit-optimized-test-inst x
1262 `(constantize (fixnumize y
)))
1263 ((-c/signed -c
/unsigned
)
1267 (define-logtest-vops))
1269 (defknown %logbitp
(integer unsigned-byte
) boolean
1270 (movable foldable flushable always-translatable
))
1272 ;;; only for constant folding within the compiler
1273 (defun %logbitp
(integer index
)
1274 (logbitp index integer
))
1276 ;;; too much work to do the non-constant case (maybe?)
1277 (define-vop (fast-logbitp-c/fixnum fast-conditional-c
/fixnum
)
1278 (:translate %logbitp
)
1280 (:arg-types tagged-num
(:constant
(integer 0 #.
(- 63 n-fixnum-tag-bits
))))
1282 (inst bt x
(+ y n-fixnum-tag-bits
))))
1284 (define-vop (fast-logbitp/signed fast-conditional
/signed
)
1285 (:args
(x :scs
(signed-reg signed-stack
))
1286 (y :scs
(signed-reg)))
1287 (:translate %logbitp
)
1292 (define-vop (fast-logbitp-c/signed fast-conditional-c
/signed
)
1293 (:translate %logbitp
)
1295 (:arg-types signed-num
(:constant
(integer 0 63)))
1299 (define-vop (fast-logbitp/unsigned fast-conditional
/unsigned
)
1300 (:args
(x :scs
(unsigned-reg unsigned-stack
))
1301 (y :scs
(unsigned-reg)))
1302 (:translate %logbitp
)
1307 (define-vop (fast-logbitp-c/unsigned fast-conditional-c
/unsigned
)
1308 (:translate %logbitp
)
1310 (:arg-types unsigned-num
(:constant
(integer 0 63)))
1314 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned
)
1315 (declare (ignore not-cond not-unsigned
))
1318 (lambda (suffix cost signed
)
1319 `(define-vop (,(symbolicate "FAST-IF-" tran suffix
)
1320 ,(symbolicate "FAST-CONDITIONAL" suffix
))
1322 (:conditional
,(if signed cond unsigned
))
1324 (cond ((and (sc-is x any-reg signed-reg unsigned-reg
)
1331 `(constantize (fixnumize y
)))
1332 ((-c/signed -c
/unsigned
)
1335 '(/fixnum -c
/fixnum
/signed -c
/signed
/unsigned -c
/unsigned
)
1336 ; '(/fixnum /signed /unsigned)
1338 '(t t t t nil nil
)))))
1340 (define-conditional-vop < :l
:b
:ge
:ae
)
1341 (define-conditional-vop > :g
:a
:le
:be
))
1343 (define-vop (fast-if-eql/signed fast-conditional
/signed
)
1344 (:translate eql %eql
/integer
)
1348 (define-vop (fast-if-eql-c/signed fast-conditional-c
/signed
)
1349 (:translate eql %eql
/integer
)
1351 (cond ((and (sc-is x signed-reg
) (zerop y
))
1352 (inst test x x
)) ; smaller instruction
1354 (inst cmp x
(constantize y
))))))
1356 (define-vop (fast-if-eql/unsigned fast-conditional
/unsigned
)
1357 (:translate eql %eql
/integer
)
1361 (define-vop (fast-if-eql-c/unsigned fast-conditional-c
/unsigned
)
1362 (:translate eql %eql
/integer
)
1364 (cond ((and (sc-is x unsigned-reg
) (zerop y
))
1365 (inst test x x
)) ; smaller instruction
1367 (inst cmp x
(constantize y
))))))
1369 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
1372 ;;; These versions specify a fixnum restriction on their first arg. We have
1373 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
1374 ;;; the first arg and a higher cost. The reason for doing this is to prevent
1375 ;;; fixnum specific operations from being used on word integers, spuriously
1376 ;;; consing the argument.
1378 (define-vop (fast-eql/fixnum fast-conditional
)
1379 (:args
(x :scs
(any-reg)
1380 :load-if
(not (and (sc-is x control-stack
)
1381 (sc-is y any-reg
))))
1382 (y :scs
(any-reg control-stack
)))
1383 (:arg-types tagged-num tagged-num
)
1384 (:note
"inline fixnum comparison")
1385 (:translate eql %eql
/integer
)
1389 (define-vop (generic-eql/fixnum fast-eql
/fixnum
)
1390 (:args
(x :scs
(any-reg descriptor-reg
)
1391 :load-if
(not (and (sc-is x control-stack
)
1392 (sc-is y any-reg
))))
1393 (y :scs
(any-reg control-stack
)))
1394 (:arg-types
* tagged-num
)
1397 (define-vop (fast-eql-c/fixnum fast-conditional-c
/fixnum
)
1398 (:args
(x :scs
(any-reg) :load-if t
))
1399 (:arg-types tagged-num
(:constant fixnum
))
1402 (:policy
:fast-safe
)
1403 (:translate eql %eql
/integer
)
1405 (cond ((and (sc-is x any-reg descriptor-reg
) (zerop y
))
1406 (inst test x x
)) ; smaller instruction
1408 (inst cmp x
(constantize (fixnumize y
)))))))
1410 (define-vop (generic-eql-c/fixnum fast-eql-c
/fixnum
)
1411 (:args
(x :scs
(any-reg descriptor-reg
) :load-if t
))
1412 (:arg-types
* (:constant fixnum
))
1415 ;;;; 64-bit logical operations
1417 ;;; Only the lower 6 bits of the shift amount are significant.
1418 (define-vop (shift-towards-someplace)
1419 (:policy
:fast-safe
)
1420 (:args
(num :scs
(unsigned-reg) :target r
)
1421 (amount :scs
(signed-reg) :target ecx
))
1422 (:arg-types unsigned-num tagged-num
)
1423 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
1424 (:results
(r :scs
(unsigned-reg) :from
(:argument
0)))
1425 (:result-types unsigned-num
))
1427 (define-vop (shift-towards-start shift-towards-someplace
)
1428 (:translate shift-towards-start
)
1429 (:note
"SHIFT-TOWARDS-START")
1435 (define-vop (shift-towards-end shift-towards-someplace
)
1436 (:translate shift-towards-end
)
1437 (:note
"SHIFT-TOWARDS-END")
1443 ;;;; Modular functions
1445 (defmacro define-mod-binop
((name prototype
) function
)
1446 `(define-vop (,name
,prototype
)
1447 (:args
(x :target r
:scs
(unsigned-reg signed-reg
)
1448 :load-if
(not (and (or (sc-is x unsigned-stack
)
1449 (sc-is x signed-stack
))
1450 (or (sc-is y unsigned-reg
)
1451 (sc-is y signed-reg
))
1452 (or (sc-is r unsigned-stack
)
1453 (sc-is r signed-stack
))
1455 (y :scs
(unsigned-reg signed-reg unsigned-stack signed-stack
)))
1456 (:arg-types untagged-num untagged-num
)
1457 (:results
(r :scs
(unsigned-reg signed-reg
) :from
(:argument
0)
1458 :load-if
(not (and (or (sc-is x unsigned-stack
)
1459 (sc-is x signed-stack
))
1460 (or (sc-is y unsigned-reg
)
1461 (sc-is y unsigned-reg
))
1462 (or (sc-is r unsigned-stack
)
1463 (sc-is r unsigned-stack
))
1465 (:result-types unsigned-num
)
1466 (:translate
,function
)))
1467 (defmacro define-mod-binop-c
((name prototype
) function
)
1468 `(define-vop (,name
,prototype
)
1469 (:args
(x :target r
:scs
(unsigned-reg signed-reg
)
1472 (:arg-types untagged-num
(:constant
(or (unsigned-byte 64) (signed-byte 64))))
1473 (:results
(r :scs
(unsigned-reg signed-reg
) :from
(:argument
0)
1475 (:result-types unsigned-num
)
1476 (:translate
,function
)))
1478 (macrolet ((def (name -c-p
)
1479 (let ((fun64 (intern (format nil
"~S-MOD64" name
)))
1480 (vopu (intern (format nil
"FAST-~S/UNSIGNED=>UNSIGNED" name
)))
1481 (vopcu (intern (format nil
"FAST-~S-C/UNSIGNED=>UNSIGNED" name
)))
1482 (vopf (intern (format nil
"FAST-~S/FIXNUM=>FIXNUM" name
)))
1483 (vopcf (intern (format nil
"FAST-~S-C/FIXNUM=>FIXNUM" name
)))
1484 (vop64u (intern (format nil
"FAST-~S-MOD64/WORD=>UNSIGNED" name
)))
1485 (vop64f (intern (format nil
"FAST-~S-MOD64/FIXNUM=>FIXNUM" name
)))
1486 (vop64cu (intern (format nil
"FAST-~S-MOD64-C/WORD=>UNSIGNED" name
)))
1487 (vop64cf (intern (format nil
"FAST-~S-MOD64-C/FIXNUM=>FIXNUM" name
)))
1488 (funfx (intern (format nil
"~S-MODFX" name
)))
1489 (vopfxf (intern (format nil
"FAST-~S-MODFX/FIXNUM=>FIXNUM" name
)))
1490 (vopfxcf (intern (format nil
"FAST-~S-MODFX-C/FIXNUM=>FIXNUM" name
))))
1491 (declare (ignore vop64cf
)) ; maybe someone will want it some day
1493 (define-modular-fun ,fun64
(x y
) ,name
:untagged nil
64)
1494 (define-modular-fun ,funfx
(x y
) ,name
:tagged t
1495 #.
(- n-word-bits n-fixnum-tag-bits
))
1496 (define-mod-binop (,vop64u
,vopu
) ,fun64
)
1497 (define-vop (,vop64f
,vopf
) (:translate
,fun64
))
1498 (define-vop (,vopfxf
,vopf
) (:translate
,funfx
))
1500 `((define-mod-binop-c (,vop64cu
,vopcu
) ,fun64
)
1501 (define-vop (,vopfxcf
,vopcf
) (:translate
,funfx
))))))))
1506 (define-modular-fun %negate-mod64
(x) %negate
:untagged nil
64)
1507 (define-vop (%negate-mod64
)
1508 (:translate %negate-mod64
)
1509 (:policy
:fast-safe
)
1510 (:args
(x :scs
(unsigned-reg) :target r
))
1511 (:arg-types unsigned-num
)
1512 (:results
(r :scs
(unsigned-reg)))
1513 (:result-types unsigned-num
)
1518 (define-modular-fun %negate-modfx
(x) %negate
:tagged t
#.
(- n-word-bits
1520 (define-vop (%negate-modfx fast-negate
/fixnum
)
1521 (:translate %negate-modfx
))
1523 (define-vop (fast-ash-left-mod64-c/unsigned
=>unsigned
1524 fast-ash-c
/unsigned
=>unsigned
)
1525 (:translate ash-left-mod64
))
1526 (define-vop (fast-ash-left-mod64/unsigned
=>unsigned
1527 fast-ash-left
/unsigned
=>unsigned
))
1528 (deftransform ash-left-mod64
((integer count
)
1529 ((unsigned-byte 64) (unsigned-byte 6)))
1530 (when (sb!c
::constant-lvar-p count
)
1531 (sb!c
::give-up-ir1-transform
))
1532 '(%primitive fast-ash-left-mod64
/unsigned
=>unsigned integer count
))
1534 (define-vop (fast-ash-left-modfx-c/fixnum
=>fixnum
1535 fast-ash-c
/fixnum
=>fixnum
)
1537 (:translate ash-left-modfx
))
1538 (define-vop (fast-ash-left-modfx/fixnum
=>fixnum
1539 fast-ash-left
/fixnum
=>fixnum
))
1540 (deftransform ash-left-modfx
((integer count
)
1541 (fixnum (unsigned-byte 6)))
1542 (when (sb!c
::constant-lvar-p count
)
1543 (sb!c
::give-up-ir1-transform
))
1544 '(%primitive fast-ash-left-modfx
/fixnum
=>fixnum integer count
))
1548 (defknown sb
!vm
::%lea-mod64
(integer integer
(member 1 2 4 8) (signed-byte 64))
1550 (foldable flushable movable
))
1551 (defknown sb
!vm
::%lea-modfx
(integer integer
(member 1 2 4 8) (signed-byte 64))
1553 (foldable flushable movable
))
1555 (define-modular-fun-optimizer %lea
((base index scale disp
) :untagged nil
:width width
)
1556 (when (and (<= width
64)
1557 (constant-lvar-p scale
)
1558 (constant-lvar-p disp
))
1559 (cut-to-width base
:untagged width nil
)
1560 (cut-to-width index
:untagged width nil
)
1561 'sb
!vm
::%lea-mod64
))
1562 (define-modular-fun-optimizer %lea
((base index scale disp
) :tagged t
:width width
)
1563 (when (and (<= width
(- sb
!vm
:n-word-bits sb
!vm
:n-fixnum-tag-bits
))
1564 (constant-lvar-p scale
)
1565 (constant-lvar-p disp
))
1566 (cut-to-width base
:tagged width t
)
1567 (cut-to-width index
:tagged width t
)
1568 'sb
!vm
::%lea-modfx
))
1572 (defun sb!vm
::%lea-mod64
(base index scale disp
)
1573 (ldb (byte 64 0) (%lea base index scale disp
)))
1574 (defun sb!vm
::%lea-modfx
(base index scale disp
)
1575 (mask-signed-field (- sb
!vm
:n-word-bits sb
!vm
:n-fixnum-tag-bits
)
1576 (%lea base index scale disp
))))
1579 (defun sb!vm
::%lea-mod64
(base index scale disp
)
1580 (let ((base (logand base
#xffffffffffffffff
))
1581 (index (logand index
#xffffffffffffffff
)))
1582 ;; can't use modular version of %LEA, as we only have VOPs for
1583 ;; constant SCALE and DISP.
1584 (ldb (byte 64 0) (+ base
(* index scale
) disp
))))
1585 (defun sb!vm
::%lea-modfx
(base index scale disp
)
1586 (let* ((fixnum-width (- sb
!vm
:n-word-bits sb
!vm
:n-fixnum-tag-bits
))
1587 (base (mask-signed-field fixnum-width base
))
1588 (index (mask-signed-field fixnum-width index
)))
1589 ;; can't use modular version of %LEA, as we only have VOPs for
1590 ;; constant SCALE and DISP.
1591 (mask-signed-field fixnum-width
(+ base
(* index scale
) disp
)))))
1593 (in-package "SB!VM")
1595 (define-vop (%lea-mod64
/unsigned
=>unsigned
1596 %lea
/unsigned
=>unsigned
)
1597 (:translate %lea-mod64
))
1598 (define-vop (%lea-modfx
/fixnum
=>fixnum
1599 %lea
/fixnum
=>fixnum
)
1600 (:translate %lea-modfx
))
1602 ;;; logical operations
1603 (define-modular-fun lognot-mod64
(x) lognot
:untagged nil
64)
1604 (define-vop (lognot-mod64/unsigned
=>unsigned
)
1605 (:translate lognot-mod64
)
1606 (:args
(x :scs
(unsigned-reg unsigned-stack
) :target r
1607 :load-if
(not (and (sc-is x unsigned-stack
)
1608 (sc-is r unsigned-stack
)
1610 (:arg-types unsigned-num
)
1611 (:results
(r :scs
(unsigned-reg)
1612 :load-if
(not (and (sc-is x unsigned-stack
)
1613 (sc-is r unsigned-stack
)
1615 (:result-types unsigned-num
)
1616 (:policy
:fast-safe
)
1621 (define-source-transform logeqv
(&rest args
)
1622 (if (oddp (length args
))
1624 `(lognot (logxor ,@args
))))
1625 (define-source-transform logandc1
(x y
)
1626 `(logand (lognot ,x
) ,y
))
1627 (define-source-transform logandc2
(x y
)
1628 `(logand ,x
(lognot ,y
)))
1629 (define-source-transform logorc1
(x y
)
1630 `(logior (lognot ,x
) ,y
))
1631 (define-source-transform logorc2
(x y
)
1632 `(logior ,x
(lognot ,y
)))
1633 (define-source-transform lognor
(x y
)
1634 `(lognot (logior ,x
,y
)))
1635 (define-source-transform lognand
(x y
)
1636 `(lognot (logand ,x
,y
)))
1640 (define-vop (bignum-length get-header-data
)
1641 (:translate sb
!bignum
:%bignum-length
)
1642 (:policy
:fast-safe
))
1644 (define-vop (bignum-set-length set-header-data
)
1645 (:translate sb
!bignum
:%bignum-set-length
)
1646 (:policy
:fast-safe
))
1648 (define-full-reffer bignum-ref
* bignum-digits-offset other-pointer-lowtag
1649 (unsigned-reg) unsigned-num sb
!bignum
:%bignum-ref
)
1650 (define-full-reffer+offset bignum-ref-with-offset
* bignum-digits-offset
1651 other-pointer-lowtag
(unsigned-reg) unsigned-num
1652 sb
!bignum
:%bignum-ref-with-offset
)
1653 (define-full-setter bignum-set
* bignum-digits-offset other-pointer-lowtag
1654 (unsigned-reg) unsigned-num sb
!bignum
:%bignum-set
)
1656 (define-vop (digit-0-or-plus)
1657 (:translate sb
!bignum
:%digit-0-or-plusp
)
1658 (:policy
:fast-safe
)
1659 (:args
(digit :scs
(unsigned-reg)))
1660 (:arg-types unsigned-num
)
1663 (inst test digit digit
)))
1666 ;;; For add and sub with carry the sc of carry argument is any-reg so
1667 ;;; that it may be passed as a fixnum or word and thus may be 0, 1, or
1668 ;;; 8. This is easy to deal with and may save a fixnum-word
1670 (define-vop (add-w/carry
)
1671 (:translate sb
!bignum
:%add-with-carry
)
1672 (:policy
:fast-safe
)
1673 (:args
(a :scs
(unsigned-reg) :target result
)
1674 (b :scs
(unsigned-reg unsigned-stack
) :to
:eval
)
1675 (c :scs
(any-reg) :target temp
))
1676 (:arg-types unsigned-num unsigned-num positive-fixnum
)
1677 (:temporary
(:sc any-reg
:from
(:argument
2) :to
:eval
) temp
)
1678 (:results
(result :scs
(unsigned-reg) :from
(:argument
0))
1679 (carry :scs
(unsigned-reg)))
1680 (:result-types unsigned-num positive-fixnum
)
1684 (inst neg temp
) ; Set the carry flag to 0 if c=0 else to 1
1687 (inst adc carry carry
)))
1689 ;;; Note: the borrow is 1 for no borrow and 0 for a borrow, the opposite
1690 ;;; of the x86-64 convention.
1691 (define-vop (sub-w/borrow
)
1692 (:translate sb
!bignum
:%subtract-with-borrow
)
1693 (:policy
:fast-safe
)
1694 (:args
(a :scs
(unsigned-reg) :to
:eval
:target result
)
1695 (b :scs
(unsigned-reg unsigned-stack
) :to
:result
)
1696 (c :scs
(any-reg control-stack
)))
1697 (:arg-types unsigned-num unsigned-num positive-fixnum
)
1698 (:results
(result :scs
(unsigned-reg) :from
:eval
)
1699 (borrow :scs
(unsigned-reg)))
1700 (:result-types unsigned-num positive-fixnum
)
1702 (inst cmp c
1) ; Set the carry flag to 1 if c=0 else to 0
1706 (inst sbb borrow
0)))
1709 (define-vop (bignum-mult-and-add-3-arg)
1710 (:translate sb
!bignum
:%multiply-and-add
)
1711 (:policy
:fast-safe
)
1712 (:args
(x :scs
(unsigned-reg) :target eax
)
1713 (y :scs
(unsigned-reg unsigned-stack
))
1714 (carry-in :scs
(unsigned-reg unsigned-stack
)))
1715 (:arg-types unsigned-num unsigned-num unsigned-num
)
1716 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0)
1717 :to
(:result
1) :target lo
) eax
)
1718 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
1)
1719 :to
(:result
0) :target hi
) edx
)
1720 (:results
(hi :scs
(unsigned-reg))
1721 (lo :scs
(unsigned-reg)))
1722 (:result-types unsigned-num unsigned-num
)
1726 (inst add eax carry-in
)
1731 (define-vop (bignum-mult-and-add-4-arg)
1732 (:translate sb
!bignum
:%multiply-and-add
)
1733 (:policy
:fast-safe
)
1734 (:args
(x :scs
(unsigned-reg) :target eax
)
1735 (y :scs
(unsigned-reg unsigned-stack
))
1736 (prev :scs
(unsigned-reg unsigned-stack
))
1737 (carry-in :scs
(unsigned-reg unsigned-stack
)))
1738 (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num
)
1739 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0)
1740 :to
(:result
1) :target lo
) eax
)
1741 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
1)
1742 :to
(:result
0) :target hi
) edx
)
1743 (:results
(hi :scs
(unsigned-reg))
1744 (lo :scs
(unsigned-reg)))
1745 (:result-types unsigned-num unsigned-num
)
1751 (inst add eax carry-in
)
1757 (define-vop (bignum-mult)
1758 (:translate sb
!bignum
:%multiply
)
1759 (:policy
:fast-safe
)
1760 (:args
(x :scs
(unsigned-reg) :target eax
)
1761 (y :scs
(unsigned-reg unsigned-stack
)))
1762 (:arg-types unsigned-num unsigned-num
)
1763 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0)
1764 :to
(:result
1) :target lo
) eax
)
1765 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
1)
1766 :to
(:result
0) :target hi
) edx
)
1767 (:results
(hi :scs
(unsigned-reg))
1768 (lo :scs
(unsigned-reg)))
1769 (:result-types unsigned-num unsigned-num
)
1776 #!+multiply-high-vops
1778 (:translate %multiply-high
)
1779 (:policy
:fast-safe
)
1780 (:args
(x :scs
(unsigned-reg) :target eax
)
1781 (y :scs
(unsigned-reg unsigned-stack
)))
1782 (:arg-types unsigned-num unsigned-num
)
1783 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0))
1785 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
1)
1786 :to
(:result
0) :target hi
) edx
)
1787 (:results
(hi :scs
(unsigned-reg)))
1788 (:result-types unsigned-num
)
1794 #!+multiply-high-vops
1795 (define-vop (mulhi/fx
)
1796 (:translate %multiply-high
)
1797 (:policy
:fast-safe
)
1798 (:args
(x :scs
(any-reg) :target eax
)
1799 (y :scs
(unsigned-reg unsigned-stack
)))
1800 (:arg-types positive-fixnum unsigned-num
)
1801 (:temporary
(:sc any-reg
:offset eax-offset
:from
(:argument
0)) eax
)
1802 (:temporary
(:sc any-reg
:offset edx-offset
:from
(:argument
1)
1803 :to
(:result
0) :target hi
) edx
)
1804 (:results
(hi :scs
(any-reg)))
1805 (:result-types positive-fixnum
)
1810 (inst and hi
(lognot fixnum-tag-mask
))))
1812 (define-vop (bignum-lognot lognot-mod64
/unsigned
=>unsigned
)
1813 (:translate sb
!bignum
:%lognot
))
1815 (define-vop (fixnum-to-digit)
1816 (:translate sb
!bignum
:%fixnum-to-digit
)
1817 (:policy
:fast-safe
)
1818 (:args
(fixnum :scs
(any-reg control-stack
) :target digit
))
1819 (:arg-types tagged-num
)
1820 (:results
(digit :scs
(unsigned-reg)
1821 :load-if
(not (and (sc-is fixnum control-stack
)
1822 (sc-is digit unsigned-stack
)
1823 (location= fixnum digit
)))))
1824 (:result-types unsigned-num
)
1827 (inst sar digit n-fixnum-tag-bits
)))
1829 (define-vop (bignum-floor)
1830 (:translate sb
!bignum
:%bigfloor
)
1831 (:policy
:fast-safe
)
1832 (:args
(div-high :scs
(unsigned-reg) :target edx
)
1833 (div-low :scs
(unsigned-reg) :target eax
)
1834 (divisor :scs
(unsigned-reg unsigned-stack
)))
1835 (:arg-types unsigned-num unsigned-num unsigned-num
)
1836 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
1)
1837 :to
(:result
0) :target quo
) eax
)
1838 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
0)
1839 :to
(:result
1) :target rem
) edx
)
1840 (:results
(quo :scs
(unsigned-reg))
1841 (rem :scs
(unsigned-reg)))
1842 (:result-types unsigned-num unsigned-num
)
1846 (inst div eax divisor
)
1850 (define-vop (signify-digit)
1851 (:translate sb
!bignum
:%fixnum-digit-with-correct-sign
)
1852 (:policy
:fast-safe
)
1853 (:args
(digit :scs
(unsigned-reg unsigned-stack
) :target res
))
1854 (:arg-types unsigned-num
)
1855 (:results
(res :scs
(any-reg signed-reg
)
1856 :load-if
(not (and (sc-is digit unsigned-stack
)
1857 (sc-is res control-stack signed-stack
)
1858 (location= digit res
)))))
1859 (:result-types signed-num
)
1862 (when (sc-is res any-reg control-stack
)
1863 (inst shl res n-fixnum-tag-bits
))))
1865 (define-vop (digit-ashr)
1866 (:translate sb
!bignum
:%ashr
)
1867 (:policy
:fast-safe
)
1868 (:args
(digit :scs
(unsigned-reg unsigned-stack
) :target result
)
1869 (count :scs
(unsigned-reg) :target ecx
))
1870 (:arg-types unsigned-num positive-fixnum
)
1871 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
1872 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)
1873 :load-if
(not (and (sc-is result unsigned-stack
)
1874 (location= digit result
)))))
1875 (:result-types unsigned-num
)
1879 (inst sar result
:cl
)))
1881 (define-vop (digit-ashr/c
)
1882 (:translate sb
!bignum
:%ashr
)
1883 (:policy
:fast-safe
)
1884 (:args
(digit :scs
(unsigned-reg unsigned-stack
) :target result
))
1885 (:arg-types unsigned-num
(:constant
(integer 0 63)))
1887 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)
1888 :load-if
(not (and (sc-is result unsigned-stack
)
1889 (location= digit result
)))))
1890 (:result-types unsigned-num
)
1893 (inst sar result count
)))
1895 (define-vop (digit-lshr digit-ashr
)
1896 (:translate sb
!bignum
:%digit-logical-shift-right
)
1900 (inst shr result
:cl
)))
1902 (define-vop (digit-ashl digit-ashr
)
1903 (:translate sb
!bignum
:%ashl
)
1907 (inst shl result
:cl
)))
1909 (define-vop (logand-bignum/c
)
1911 (:policy
:fast-safe
)
1912 (:args
(x :scs
(descriptor-reg)))
1913 (:arg-types bignum
(:constant word
))
1914 (:results
(r :scs
(unsigned-reg)))
1916 (:result-types unsigned-num
)
1918 (cond ((or (immediate32-p mask
)
1920 (loadw r x bignum-digits-offset other-pointer-lowtag
)
1921 (unless (or (eql mask -
1)
1922 (eql mask
(ldb (byte n-word-bits
0) -
1)))
1923 (inst and r
(constantize mask
))))
1926 (inst and r
(make-ea-for-object-slot x
1927 bignum-digits-offset
1928 other-pointer-lowtag
))))))
1930 ;; Specialised mask-signed-field VOPs.
1931 (define-vop (mask-signed-field-word/c
)
1932 (:translate sb
!c
::mask-signed-field
)
1933 (:policy
:fast-safe
)
1934 (:args
(x :scs
(signed-reg unsigned-reg
) :target r
))
1935 (:arg-types
(:constant
(integer 0 64)) untagged-num
)
1936 (:results
(r :scs
(signed-reg)))
1937 (:result-types signed-num
)
1940 (cond ((zerop width
)
1944 ((member width
'(32 16 8))
1945 (inst movsx r
(reg-in-size x
(ecase width
1951 (let ((delta (- n-word-bits width
)))
1953 (inst sar r delta
))))))
1955 (define-vop (mask-signed-field-bignum/c
)
1956 (:translate sb
!c
::mask-signed-field
)
1957 (:policy
:fast-safe
)
1958 (:args
(x :scs
(descriptor-reg) :target r
))
1959 (:arg-types
(:constant
(integer 0 64)) bignum
)
1960 (:results
(r :scs
(signed-reg)))
1961 (:result-types signed-num
)
1964 (cond ((zerop width
)
1966 ((member width
'(8 16 32 64))
1968 (64 (loadw r x bignum-digits-offset other-pointer-lowtag
))
1970 (inst movsx r
(make-ea (ecase width
(32 :dword
) (16 :word
) (8 :byte
))
1972 :disp
(- (* bignum-digits-offset n-word-bytes
)
1973 other-pointer-lowtag
))))))
1975 (loadw r x bignum-digits-offset other-pointer-lowtag
)
1976 (let ((delta (- n-word-bits width
)))
1978 (inst sar r delta
))))))
1980 (define-vop (mask-signed-field-fixnum)
1981 (:translate sb
!c
::mask-signed-field
)
1982 (:policy
:fast-safe
)
1983 (:args
(x :scs
(descriptor-reg) :target r
))
1984 (:arg-types
(:constant
(eql #.n-fixnum-bits
)) t
)
1985 (:results
(r :scs
(any-reg)))
1986 (:result-types fixnum
)
1991 (generate-fixnum-test r
)
1993 (loadw r r bignum-digits-offset other-pointer-lowtag
)
1994 (inst shl r
(- n-word-bits n-fixnum-bits
))
1997 (define-vop (logand-word-mask)
1999 (:policy
:fast-safe
)
2000 (:args
(x :scs
(descriptor-reg)))
2001 (:arg-types t
(:constant word
))
2002 (:results
(r :scs
(unsigned-reg)))
2004 (:result-types unsigned-num
)
2006 (let ((fixnum-mask-p (and (= n-fixnum-tag-bits
1)
2007 (= mask
(ash most-positive-word -
1)))))
2010 (generate-fixnum-test r
)
2011 (inst jmp
:nz BIGNUM
)
2013 (inst shr r n-fixnum-tag-bits
)
2014 (inst sar r n-fixnum-tag-bits
))
2017 (loadw r x bignum-digits-offset other-pointer-lowtag
)
2019 (inst btr r
(1- n-word-bits
)))
2021 (unless (or fixnum-mask-p
2022 (= mask most-positive-word
))
2023 (inst and r
(or (immediate32-p mask
)
2024 (constantize mask
))))))))
2026 ;;;; static functions
2028 (define-static-fun two-arg-
/ (x y
) :translate
/)
2030 (define-static-fun two-arg-gcd
(x y
) :translate gcd
)
2031 (define-static-fun two-arg-lcm
(x y
) :translate lcm
)
2033 (define-static-fun two-arg-and
(x y
) :translate logand
)
2034 (define-static-fun two-arg-ior
(x y
) :translate logior
)
2035 (define-static-fun two-arg-xor
(x y
) :translate logxor
)
2040 (defun *-transformer
(y)
2042 ((= y
(ash 1 (integer-length y
)))
2043 ;; there's a generic transform for y = 2^k
2044 (give-up-ir1-transform))
2045 ((member y
'(3 5 9))
2046 ;; we can do these multiplications directly using LEA
2047 `(%lea x x
,(1- y
) 0))
2049 ;; A normal 64-bit multiplication takes 4 cycles on Athlon 64/Opteron.
2050 ;; Optimizing multiplications (other than the above cases) to
2051 ;; shifts/adds/leas gives a maximum improvement of 1 cycle, but requires
2052 ;; quite a lot of hairy code.
2053 (give-up-ir1-transform))))
2055 ;; These transforms were exceptionally noisy in an unhelpful way.
2056 ;; Reading the output would not induce the speed-conscious programmer to think
2057 ;; "I'd better code this multiply as (* (* B 2) 9) instead of (* B 18)
2058 ;; so that the LEA transform kicks in".
2059 (deftransform * ((x y
)
2060 ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
2063 "recode as leas, shifts and adds"
2064 (let ((y (lvar-value y
)))
2066 (deftransform sb
!vm
::*-mod64
2067 ((x y
) ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
2070 "recode as leas, shifts and adds"
2071 (let ((y (lvar-value y
)))
2074 (deftransform * ((x y
)
2075 (fixnum (constant-arg (unsigned-byte 64)))
2078 "recode as leas, shifts and adds"
2079 (let ((y (lvar-value y
)))
2081 (deftransform sb
!vm
::*-modfx
2082 ((x y
) (fixnum (constant-arg (unsigned-byte 64)))
2085 "recode as leas, shifts and adds"
2086 (let ((y (lvar-value y
)))