1 ;;;; the VM definition arithmetic VOPs for the x86
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
16 (define-vop (fast-safe-arith-op)
21 (define-vop (fixnum-unop fast-safe-arith-op
)
22 (:args
(x :scs
(any-reg) :target res
))
23 (:results
(res :scs
(any-reg)))
24 (:note
"inline fixnum arithmetic")
25 (:arg-types tagged-num
)
26 (:result-types tagged-num
))
28 (define-vop (signed-unop fast-safe-arith-op
)
29 (:args
(x :scs
(signed-reg) :target res
))
30 (:results
(res :scs
(signed-reg)))
31 (:note
"inline (signed-byte 32) arithmetic")
32 (:arg-types signed-num
)
33 (:result-types signed-num
))
35 (define-vop (fast-negate/fixnum fixnum-unop
)
41 (define-vop (fast-negate/signed signed-unop
)
47 (define-vop (fast-lognot/fixnum fixnum-unop
)
51 (inst xor res
(fixnumize -
1))))
53 (define-vop (fast-lognot/signed signed-unop
)
59 ;;;; binary fixnum operations
61 ;;; Assume that any constant operand is the second arg...
63 (define-vop (fast-fixnum-binop fast-safe-arith-op
)
64 (:args
(x :target r
:scs
(any-reg)
65 :load-if
(not (and (sc-is x control-stack
)
67 (sc-is r control-stack
)
69 (y :scs
(any-reg control-stack
)))
70 (:arg-types tagged-num tagged-num
)
71 (:results
(r :scs
(any-reg) :from
(:argument
0)
72 :load-if
(not (and (sc-is x control-stack
)
74 (sc-is r control-stack
)
76 (:result-types tagged-num
)
77 (:note
"inline fixnum arithmetic"))
79 (define-vop (fast-unsigned-binop fast-safe-arith-op
)
80 (:args
(x :target r
:scs
(unsigned-reg)
81 :load-if
(not (and (sc-is x unsigned-stack
)
82 (sc-is y unsigned-reg
)
83 (sc-is r unsigned-stack
)
85 (y :scs
(unsigned-reg unsigned-stack
)))
86 (:arg-types unsigned-num unsigned-num
)
87 (:results
(r :scs
(unsigned-reg) :from
(:argument
0)
88 :load-if
(not (and (sc-is x unsigned-stack
)
89 (sc-is y unsigned-reg
)
90 (sc-is r unsigned-stack
)
92 (:result-types unsigned-num
)
93 (:note
"inline (unsigned-byte 32) arithmetic"))
95 (define-vop (fast-signed-binop fast-safe-arith-op
)
96 (:args
(x :target r
:scs
(signed-reg)
97 :load-if
(not (and (sc-is x signed-stack
)
99 (sc-is r signed-stack
)
101 (y :scs
(signed-reg signed-stack
)))
102 (:arg-types signed-num signed-num
)
103 (:results
(r :scs
(signed-reg) :from
(:argument
0)
104 :load-if
(not (and (sc-is x signed-stack
)
106 (sc-is r signed-stack
)
108 (:result-types signed-num
)
109 (:note
"inline (signed-byte 32) arithmetic"))
111 (define-vop (fast-fixnum-binop-c fast-safe-arith-op
)
112 (:args
(x :target r
:scs
(any-reg control-stack
)))
114 (:arg-types tagged-num
(:constant
(signed-byte 30)))
115 (:results
(r :scs
(any-reg)
116 :load-if
(not (location= x r
))))
117 (:result-types tagged-num
)
118 (:note
"inline fixnum arithmetic"))
120 (define-vop (fast-unsigned-binop-c fast-safe-arith-op
)
121 (:args
(x :target r
:scs
(unsigned-reg unsigned-stack
)))
123 (:arg-types unsigned-num
(:constant
(unsigned-byte 32)))
124 (:results
(r :scs
(unsigned-reg)
125 :load-if
(not (location= x r
))))
126 (:result-types unsigned-num
)
127 (:note
"inline (unsigned-byte 32) arithmetic"))
129 (define-vop (fast-signed-binop-c fast-safe-arith-op
)
130 (:args
(x :target r
:scs
(signed-reg signed-stack
)))
132 (:arg-types signed-num
(:constant
(signed-byte 32)))
133 (:results
(r :scs
(signed-reg)
134 :load-if
(not (location= x r
))))
135 (:result-types signed-num
)
136 (:note
"inline (signed-byte 32) arithmetic"))
138 (macrolet ((define-binop (translate untagged-penalty op
)
140 (define-vop (,(symbolicate "FAST-" translate
"/FIXNUM=>FIXNUM")
142 (:translate
,translate
)
146 (define-vop (,(symbolicate 'fast- translate
'-c
/fixnum
=>fixnum
)
148 (:translate
,translate
)
151 (inst ,op r
(fixnumize y
))))
152 (define-vop (,(symbolicate "FAST-" translate
"/SIGNED=>SIGNED")
154 (:translate
,translate
)
155 (:generator
,(1+ untagged-penalty
)
158 (define-vop (,(symbolicate 'fast- translate
'-c
/signed
=>signed
)
160 (:translate
,translate
)
161 (:generator
,untagged-penalty
164 (define-vop (,(symbolicate "FAST-"
166 "/UNSIGNED=>UNSIGNED")
168 (:translate
,translate
)
169 (:generator
,(1+ untagged-penalty
)
172 (define-vop (,(symbolicate 'fast-
174 '-c
/unsigned
=>unsigned
)
175 fast-unsigned-binop-c
)
176 (:translate
,translate
)
177 (:generator
,untagged-penalty
181 ;;(define-binop + 4 add)
182 (define-binop -
4 sub
)
183 (define-binop logand
2 and
)
184 (define-binop logior
2 or
)
185 (define-binop logxor
2 xor
))
187 ;;; Special handling of add on the x86; can use lea to avoid a
188 ;;; register load, otherwise it uses add.
189 (define-vop (fast-+/fixnum
=>fixnum fast-safe-arith-op
)
191 (:args
(x :scs
(any-reg) :target r
192 :load-if
(not (and (sc-is x control-stack
)
194 (sc-is r control-stack
)
196 (y :scs
(any-reg control-stack
)))
197 (:arg-types tagged-num tagged-num
)
198 (:results
(r :scs
(any-reg) :from
(:argument
0)
199 :load-if
(not (and (sc-is x control-stack
)
201 (sc-is r control-stack
)
203 (:result-types tagged-num
)
204 (:note
"inline fixnum arithmetic")
206 (cond ((and (sc-is x any-reg
) (sc-is y any-reg
) (sc-is r any-reg
)
207 (not (location= x r
)))
208 (inst lea r
(make-ea :dword
:base x
:index y
:scale
1)))
213 (define-vop (fast-+-c
/fixnum
=>fixnum fast-safe-arith-op
)
215 (:args
(x :target r
:scs
(any-reg control-stack
)))
217 (:arg-types tagged-num
(:constant
(signed-byte 30)))
218 (:results
(r :scs
(any-reg)
219 :load-if
(not (location= x r
))))
220 (:result-types tagged-num
)
221 (:note
"inline fixnum arithmetic")
223 (cond ((and (sc-is x any-reg
) (sc-is r any-reg
) (not (location= x r
)))
224 (inst lea r
(make-ea :dword
:base x
:disp
(fixnumize y
))))
227 (inst add r
(fixnumize y
))))))
229 (define-vop (fast-+/signed
=>signed fast-safe-arith-op
)
231 (:args
(x :scs
(signed-reg) :target r
232 :load-if
(not (and (sc-is x signed-stack
)
234 (sc-is r signed-stack
)
236 (y :scs
(signed-reg signed-stack
)))
237 (:arg-types signed-num signed-num
)
238 (:results
(r :scs
(signed-reg) :from
(:argument
0)
239 :load-if
(not (and (sc-is x signed-stack
)
242 (:result-types signed-num
)
243 (:note
"inline (signed-byte 32) arithmetic")
245 (cond ((and (sc-is x signed-reg
) (sc-is y signed-reg
) (sc-is r signed-reg
)
246 (not (location= x r
)))
247 (inst lea r
(make-ea :dword
:base x
:index y
:scale
1)))
253 ;;;; Special logand cases: (logand signed unsigned) => unsigned
255 (define-vop (fast-logand/signed-unsigned
=>unsigned
256 fast-logand
/unsigned
=>unsigned
)
257 (:args
(x :target r
:scs
(signed-reg)
258 :load-if
(not (and (sc-is x signed-stack
)
259 (sc-is y unsigned-reg
)
260 (sc-is r unsigned-stack
)
262 (y :scs
(unsigned-reg unsigned-stack
)))
263 (:arg-types signed-num unsigned-num
))
265 (define-vop (fast-logand-c/signed-unsigned
=>unsigned
266 fast-logand-c
/unsigned
=>unsigned
)
267 (:args
(x :target r
:scs
(signed-reg signed-stack
)))
268 (:arg-types signed-num
(:constant
(unsigned-byte 32))))
270 (define-vop (fast-logand/unsigned-signed
=>unsigned
271 fast-logand
/unsigned
=>unsigned
)
272 (:args
(x :target r
:scs
(unsigned-reg)
273 :load-if
(not (and (sc-is x unsigned-stack
)
275 (sc-is r unsigned-stack
)
277 (y :scs
(signed-reg signed-stack
)))
278 (:arg-types unsigned-num signed-num
))
281 (define-vop (fast-+-c
/signed
=>signed fast-safe-arith-op
)
283 (:args
(x :target r
:scs
(signed-reg signed-stack
)))
285 (:arg-types signed-num
(:constant
(signed-byte 32)))
286 (:results
(r :scs
(signed-reg)
287 :load-if
(not (location= x r
))))
288 (:result-types signed-num
)
289 (:note
"inline (signed-byte 32) arithmetic")
291 (cond ((and (sc-is x signed-reg
) (sc-is r signed-reg
)
292 (not (location= x r
)))
293 (inst lea r
(make-ea :dword
:base x
:disp y
)))
300 (define-vop (fast-+/unsigned
=>unsigned fast-safe-arith-op
)
302 (:args
(x :scs
(unsigned-reg) :target r
303 :load-if
(not (and (sc-is x unsigned-stack
)
304 (sc-is y unsigned-reg
)
305 (sc-is r unsigned-stack
)
307 (y :scs
(unsigned-reg unsigned-stack
)))
308 (:arg-types unsigned-num unsigned-num
)
309 (:results
(r :scs
(unsigned-reg) :from
(:argument
0)
310 :load-if
(not (and (sc-is x unsigned-stack
)
311 (sc-is y unsigned-reg
)
312 (sc-is r unsigned-stack
)
314 (:result-types unsigned-num
)
315 (:note
"inline (unsigned-byte 32) arithmetic")
317 (cond ((and (sc-is x unsigned-reg
) (sc-is y unsigned-reg
)
318 (sc-is r unsigned-reg
) (not (location= x r
)))
319 (inst lea r
(make-ea :dword
:base x
:index y
:scale
1)))
324 (define-vop (fast-+-c
/unsigned
=>unsigned fast-safe-arith-op
)
326 (:args
(x :target r
:scs
(unsigned-reg unsigned-stack
)))
328 (:arg-types unsigned-num
(:constant
(unsigned-byte 32)))
329 (:results
(r :scs
(unsigned-reg)
330 :load-if
(not (location= x r
))))
331 (:result-types unsigned-num
)
332 (:note
"inline (unsigned-byte 32) arithmetic")
334 (cond ((and (sc-is x unsigned-reg
) (sc-is r unsigned-reg
)
335 (not (location= x r
)))
336 (inst lea r
(make-ea :dword
:base x
:disp y
)))
343 ;;;; multiplication and division
345 (define-vop (fast-*/fixnum
=>fixnum fast-safe-arith-op
)
347 ;; We need different loading characteristics.
348 (:args
(x :scs
(any-reg) :target r
)
349 (y :scs
(any-reg control-stack
)))
350 (:arg-types tagged-num tagged-num
)
351 (:results
(r :scs
(any-reg) :from
(:argument
0)))
352 (:result-types tagged-num
)
353 (:note
"inline fixnum arithmetic")
359 (define-vop (fast-*-c
/fixnum
=>fixnum fast-safe-arith-op
)
361 ;; We need different loading characteristics.
362 (:args
(x :scs
(any-reg control-stack
)))
364 (:arg-types tagged-num
(:constant
(signed-byte 30)))
365 (:results
(r :scs
(any-reg)))
366 (:result-types tagged-num
)
367 (:note
"inline fixnum arithmetic")
371 (define-vop (fast-*/signed
=>signed fast-safe-arith-op
)
373 ;; We need different loading characteristics.
374 (:args
(x :scs
(signed-reg) :target r
)
375 (y :scs
(signed-reg signed-stack
)))
376 (:arg-types signed-num signed-num
)
377 (:results
(r :scs
(signed-reg) :from
(:argument
0)))
378 (:result-types signed-num
)
379 (:note
"inline (signed-byte 32) arithmetic")
384 (define-vop (fast-*-c
/signed
=>signed fast-safe-arith-op
)
386 ;; We need different loading characteristics.
387 (:args
(x :scs
(signed-reg signed-stack
)))
389 (:arg-types signed-num
(:constant
(signed-byte 32)))
390 (:results
(r :scs
(signed-reg)))
391 (:result-types signed-num
)
392 (:note
"inline (signed-byte 32) arithmetic")
396 (define-vop (fast-*/unsigned
=>unsigned fast-safe-arith-op
)
398 (:args
(x :scs
(unsigned-reg) :target eax
)
399 (y :scs
(unsigned-reg unsigned-stack
)))
400 (:arg-types unsigned-num unsigned-num
)
401 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target result
402 :from
(:argument
0) :to
:result
) eax
)
403 (:temporary
(:sc unsigned-reg
:offset edx-offset
404 :from
:eval
:to
:result
) edx
)
406 (:results
(result :scs
(unsigned-reg)))
407 (:result-types unsigned-num
)
408 (:note
"inline (unsigned-byte 32) arithmetic")
410 (:save-p
:compute-only
)
417 (define-vop (fast-truncate/fixnum
=>fixnum fast-safe-arith-op
)
418 (:translate truncate
)
419 (:args
(x :scs
(any-reg) :target eax
)
420 (y :scs
(any-reg control-stack
)))
421 (:arg-types tagged-num tagged-num
)
422 (:temporary
(:sc signed-reg
:offset eax-offset
:target quo
423 :from
(:argument
0) :to
(:result
0)) eax
)
424 (:temporary
(:sc unsigned-reg
:offset edx-offset
:target rem
425 :from
(:argument
0) :to
(:result
1)) edx
)
426 (:results
(quo :scs
(any-reg))
427 (rem :scs
(any-reg)))
428 (:result-types tagged-num tagged-num
)
429 (:note
"inline fixnum arithmetic")
431 (:save-p
:compute-only
)
433 (let ((zero (generate-error-code vop division-by-zero-error x y
)))
434 (if (sc-is y any-reg
)
435 (inst test y y
) ; smaller instruction
441 (if (location= quo eax
)
443 (inst lea quo
(make-ea :dword
:index eax
:scale
4)))
446 (define-vop (fast-truncate-c/fixnum
=>fixnum fast-safe-arith-op
)
447 (:translate truncate
)
448 (:args
(x :scs
(any-reg) :target eax
))
450 (:arg-types tagged-num
(:constant
(signed-byte 30)))
451 (:temporary
(:sc signed-reg
:offset eax-offset
:target quo
452 :from
:argument
:to
(:result
0)) eax
)
453 (:temporary
(:sc any-reg
:offset edx-offset
:target rem
454 :from
:eval
:to
(:result
1)) edx
)
455 (:temporary
(:sc any-reg
:from
:eval
:to
:result
) y-arg
)
456 (:results
(quo :scs
(any-reg))
457 (rem :scs
(any-reg)))
458 (:result-types tagged-num tagged-num
)
459 (:note
"inline fixnum arithmetic")
461 (:save-p
:compute-only
)
465 (inst mov y-arg
(fixnumize y
))
466 (inst idiv eax y-arg
)
467 (if (location= quo eax
)
469 (inst lea quo
(make-ea :dword
:index eax
:scale
4)))
472 (define-vop (fast-truncate/unsigned
=>unsigned fast-safe-arith-op
)
473 (:translate truncate
)
474 (:args
(x :scs
(unsigned-reg) :target eax
)
475 (y :scs
(unsigned-reg signed-stack
)))
476 (:arg-types unsigned-num unsigned-num
)
477 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target quo
478 :from
(:argument
0) :to
(:result
0)) eax
)
479 (:temporary
(:sc unsigned-reg
:offset edx-offset
:target rem
480 :from
(:argument
0) :to
(:result
1)) edx
)
481 (:results
(quo :scs
(unsigned-reg))
482 (rem :scs
(unsigned-reg)))
483 (:result-types unsigned-num unsigned-num
)
484 (:note
"inline (unsigned-byte 32) arithmetic")
486 (:save-p
:compute-only
)
488 (let ((zero (generate-error-code vop division-by-zero-error x y
)))
489 (if (sc-is y unsigned-reg
)
490 (inst test y y
) ; smaller instruction
499 (define-vop (fast-truncate-c/unsigned
=>unsigned fast-safe-arith-op
)
500 (:translate truncate
)
501 (:args
(x :scs
(unsigned-reg) :target eax
))
503 (:arg-types unsigned-num
(:constant
(unsigned-byte 32)))
504 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target quo
505 :from
:argument
:to
(:result
0)) eax
)
506 (:temporary
(:sc unsigned-reg
:offset edx-offset
:target rem
507 :from
:eval
:to
(:result
1)) edx
)
508 (:temporary
(:sc unsigned-reg
:from
:eval
:to
:result
) y-arg
)
509 (:results
(quo :scs
(unsigned-reg))
510 (rem :scs
(unsigned-reg)))
511 (:result-types unsigned-num unsigned-num
)
512 (:note
"inline (unsigned-byte 32) arithmetic")
514 (:save-p
:compute-only
)
523 (define-vop (fast-truncate/signed
=>signed fast-safe-arith-op
)
524 (:translate truncate
)
525 (:args
(x :scs
(signed-reg) :target eax
)
526 (y :scs
(signed-reg signed-stack
)))
527 (:arg-types signed-num signed-num
)
528 (:temporary
(:sc signed-reg
:offset eax-offset
:target quo
529 :from
(:argument
0) :to
(:result
0)) eax
)
530 (:temporary
(:sc signed-reg
:offset edx-offset
:target rem
531 :from
(:argument
0) :to
(:result
1)) edx
)
532 (:results
(quo :scs
(signed-reg))
533 (rem :scs
(signed-reg)))
534 (:result-types signed-num signed-num
)
535 (:note
"inline (signed-byte 32) arithmetic")
537 (:save-p
:compute-only
)
539 (let ((zero (generate-error-code vop division-by-zero-error x y
)))
540 (if (sc-is y signed-reg
)
541 (inst test y y
) ; smaller instruction
550 (define-vop (fast-truncate-c/signed
=>signed fast-safe-arith-op
)
551 (:translate truncate
)
552 (:args
(x :scs
(signed-reg) :target eax
))
554 (:arg-types signed-num
(:constant
(signed-byte 32)))
555 (:temporary
(:sc signed-reg
:offset eax-offset
:target quo
556 :from
:argument
:to
(:result
0)) eax
)
557 (:temporary
(:sc signed-reg
:offset edx-offset
:target rem
558 :from
:eval
:to
(:result
1)) edx
)
559 (:temporary
(:sc signed-reg
:from
:eval
:to
:result
) y-arg
)
560 (:results
(quo :scs
(signed-reg))
561 (rem :scs
(signed-reg)))
562 (:result-types signed-num signed-num
)
563 (:note
"inline (signed-byte 32) arithmetic")
565 (:save-p
:compute-only
)
570 (inst idiv eax y-arg
)
577 (define-vop (fast-ash-c/fixnum
=>fixnum
)
580 (:args
(number :scs
(any-reg) :target result
581 :load-if
(not (and (sc-is number any-reg control-stack
)
582 (sc-is result any-reg control-stack
)
583 (location= number result
)))))
585 (:arg-types tagged-num
(:constant integer
))
586 (:results
(result :scs
(any-reg)
587 :load-if
(not (and (sc-is number control-stack
)
588 (sc-is result control-stack
)
589 (location= number result
)))))
590 (:result-types tagged-num
)
593 (cond ((and (= amount
1) (not (location= number result
)))
594 (inst lea result
(make-ea :dword
:index number
:scale
2)))
595 ((and (= amount
2) (not (location= number result
)))
596 (inst lea result
(make-ea :dword
:index number
:scale
4)))
597 ((and (= amount
3) (not (location= number result
)))
598 (inst lea result
(make-ea :dword
:index number
:scale
8)))
601 (cond ((plusp amount
)
602 ;; We don't have to worry about overflow because of the
603 ;; result type restriction.
604 (inst shl result amount
))
606 ;; If the amount is greater than 31, only shift by 31. We
607 ;; have to do this because the shift instructions only look
608 ;; at the low five bits of the result.
609 (inst sar result
(min 31 (- amount
)))
610 ;; Fixnum correction.
611 (inst and result
#xfffffffc
)))))))
613 (define-vop (fast-ash-left/fixnum
=>fixnum
)
615 (:args
(number :scs
(any-reg) :target result
616 :load-if
(not (and (sc-is number control-stack
)
617 (sc-is result control-stack
)
618 (location= number result
))))
619 (amount :scs
(unsigned-reg) :target ecx
))
620 (:arg-types tagged-num positive-fixnum
)
621 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
622 (:results
(result :scs
(any-reg) :from
(:argument
0)
623 :load-if
(not (and (sc-is number control-stack
)
624 (sc-is result control-stack
)
625 (location= number result
)))))
626 (:result-types tagged-num
)
632 ;; The result-type ensures us that this shift will not overflow.
633 (inst shl result
:cl
)))
635 (define-vop (fast-ash-c/signed
=>signed
)
638 (:args
(number :scs
(signed-reg) :target result
639 :load-if
(not (and (sc-is number signed-stack
)
640 (sc-is result signed-stack
)
641 (location= number result
)))))
643 (:arg-types signed-num
(:constant integer
))
644 (:results
(result :scs
(signed-reg)
645 :load-if
(not (and (sc-is number signed-stack
)
646 (sc-is result signed-stack
)
647 (location= number result
)))))
648 (:result-types signed-num
)
651 (cond ((and (= amount
1) (not (location= number result
)))
652 (inst lea result
(make-ea :dword
:index number
:scale
2)))
653 ((and (= amount
2) (not (location= number result
)))
654 (inst lea result
(make-ea :dword
:index number
:scale
4)))
655 ((and (= amount
3) (not (location= number result
)))
656 (inst lea result
(make-ea :dword
:index number
:scale
8)))
659 (cond ((plusp amount
) (inst shl result amount
))
660 (t (inst sar result
(min 31 (- amount
)))))))))
662 (define-vop (fast-ash-c/unsigned
=>unsigned
)
665 (:args
(number :scs
(unsigned-reg) :target result
666 :load-if
(not (and (sc-is number unsigned-stack
)
667 (sc-is result unsigned-stack
)
668 (location= number result
)))))
670 (:arg-types unsigned-num
(:constant integer
))
671 (:results
(result :scs
(unsigned-reg)
672 :load-if
(not (and (sc-is number unsigned-stack
)
673 (sc-is result unsigned-stack
)
674 (location= number result
)))))
675 (:result-types unsigned-num
)
678 (cond ((and (= amount
1) (not (location= number result
)))
679 (inst lea result
(make-ea :dword
:index number
:scale
2)))
680 ((and (= amount
2) (not (location= number result
)))
681 (inst lea result
(make-ea :dword
:index number
:scale
4)))
682 ((and (= amount
3) (not (location= number result
)))
683 (inst lea result
(make-ea :dword
:index number
:scale
8)))
686 (cond ((plusp amount
) (inst shl result amount
))
687 ((< amount -
31) (inst xor result result
))
688 (t (inst shr result
(- amount
))))))))
690 (define-vop (fast-ash-left/signed
=>signed
)
692 (:args
(number :scs
(signed-reg) :target result
693 :load-if
(not (and (sc-is number signed-stack
)
694 (sc-is result signed-stack
)
695 (location= number result
))))
696 (amount :scs
(unsigned-reg) :target ecx
))
697 (:arg-types signed-num positive-fixnum
)
698 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
699 (:results
(result :scs
(signed-reg) :from
(:argument
0)
700 :load-if
(not (and (sc-is number signed-stack
)
701 (sc-is result signed-stack
)
702 (location= number result
)))))
703 (:result-types signed-num
)
709 (inst shl result
:cl
)))
711 (define-vop (fast-ash-left/unsigned
=>unsigned
)
713 (:args
(number :scs
(unsigned-reg) :target result
714 :load-if
(not (and (sc-is number unsigned-stack
)
715 (sc-is result unsigned-stack
)
716 (location= number result
))))
717 (amount :scs
(unsigned-reg) :target ecx
))
718 (:arg-types unsigned-num positive-fixnum
)
719 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
720 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)
721 :load-if
(not (and (sc-is number unsigned-stack
)
722 (sc-is result unsigned-stack
)
723 (location= number result
)))))
724 (:result-types unsigned-num
)
730 (inst shl result
:cl
)))
732 (define-vop (fast-ash/signed
=>signed
)
735 (:args
(number :scs
(signed-reg) :target result
)
736 (amount :scs
(signed-reg) :target ecx
))
737 (:arg-types signed-num signed-num
)
738 (:results
(result :scs
(signed-reg) :from
(:argument
0)))
739 (:result-types signed-num
)
740 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
746 (inst jmp
:ns positive
)
752 (inst sar result
:cl
)
756 ;; The result-type ensures us that this shift will not overflow.
757 (inst shl result
:cl
)
761 (define-vop (fast-ash/unsigned
=>unsigned
)
764 (:args
(number :scs
(unsigned-reg) :target result
)
765 (amount :scs
(signed-reg) :target ecx
))
766 (:arg-types unsigned-num signed-num
)
767 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)))
768 (:result-types unsigned-num
)
769 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
775 (inst jmp
:ns positive
)
779 (inst xor result result
)
782 (inst shr result
:cl
)
786 ;; The result-type ensures us that this shift will not overflow.
787 (inst shl result
:cl
)
791 ;;; FIXME: before making knowledge of this too public, it needs to be
792 ;;; fixed so that it's actually _faster_ than the non-CMOV version; at
793 ;;; least on my Celeron-XXX laptop, this version is marginally slower
794 ;;; than the above version with branches. -- CSR, 2003-09-04
795 (define-vop (fast-cmov-ash/unsigned
=>unsigned
)
798 (:args
(number :scs
(unsigned-reg) :target result
)
799 (amount :scs
(signed-reg) :target ecx
))
800 (:arg-types unsigned-num signed-num
)
801 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)))
802 (:result-types unsigned-num
)
803 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
804 (:temporary
(:sc any-reg
:from
(:eval
0) :to
(:eval
1)) zero
)
806 (:guard
(member :cmov
*backend-subfeatures
*))
811 (inst jmp
:ns positive
)
814 (inst shr result
:cl
)
816 (inst cmov
:nbe result zero
)
820 ;; The result-type ensures us that this shift will not overflow.
821 (inst shl result
:cl
)
825 ;;; Note: documentation for this function is wrong - rtfm
826 (define-vop (signed-byte-32-len)
827 (:translate integer-length
)
828 (:note
"inline (signed-byte 32) integer-length")
830 (:args
(arg :scs
(signed-reg) :target res
))
831 (:arg-types signed-num
)
832 (:results
(res :scs
(unsigned-reg)))
833 (:result-types unsigned-num
)
848 (define-vop (unsigned-byte-32-len)
849 (:translate integer-length
)
850 (:note
"inline (unsigned-byte 32) integer-length")
852 (:args
(arg :scs
(unsigned-reg)))
853 (:arg-types unsigned-num
)
854 (:results
(res :scs
(unsigned-reg)))
855 (:result-types unsigned-num
)
865 (define-vop (unsigned-byte-32-count)
866 (:translate logcount
)
867 (:note
"inline (unsigned-byte 32) logcount")
869 (:args
(arg :scs
(unsigned-reg)))
870 (:arg-types unsigned-num
)
871 (:results
(result :scs
(unsigned-reg)))
872 (:result-types positive-fixnum
)
873 (:temporary
(:sc unsigned-reg
:from
(:argument
0)) temp
)
877 (inst mov temp result
)
879 (inst and result
#x55555555
)
880 (inst and temp
#x55555555
)
881 (inst add result temp
)
883 (inst mov temp result
)
885 (inst and result
#x33333333
)
886 (inst and temp
#x33333333
)
887 (inst add result temp
)
889 (inst mov temp result
)
891 (inst and result
#x0f0f0f0f
)
892 (inst and temp
#x0f0f0f0f
)
893 (inst add result temp
)
895 (inst mov temp result
)
897 (inst and result
#x00ff00ff
)
898 (inst and temp
#x00ff00ff
)
899 (inst add result temp
)
901 (inst mov temp result
)
903 (inst and result
#x0000ffff
)
904 (inst and temp
#x0000ffff
)
905 (inst add result temp
)))
907 ;;;; binary conditional VOPs
909 (define-vop (fast-conditional)
914 (:policy
:fast-safe
))
916 (define-vop (fast-conditional/fixnum fast-conditional
)
917 (:args
(x :scs
(any-reg)
918 :load-if
(not (and (sc-is x control-stack
)
920 (y :scs
(any-reg control-stack
)))
921 (:arg-types tagged-num tagged-num
)
922 (:note
"inline fixnum comparison"))
924 (define-vop (fast-conditional-c/fixnum fast-conditional
/fixnum
)
925 (:args
(x :scs
(any-reg control-stack
)))
926 (:arg-types tagged-num
(:constant
(signed-byte 30)))
927 (:info target not-p y
))
929 (define-vop (fast-conditional/signed fast-conditional
)
930 (:args
(x :scs
(signed-reg)
931 :load-if
(not (and (sc-is x signed-stack
)
932 (sc-is y signed-reg
))))
933 (y :scs
(signed-reg signed-stack
)))
934 (:arg-types signed-num signed-num
)
935 (:note
"inline (signed-byte 32) comparison"))
937 (define-vop (fast-conditional-c/signed fast-conditional
/signed
)
938 (:args
(x :scs
(signed-reg signed-stack
)))
939 (:arg-types signed-num
(:constant
(signed-byte 32)))
940 (:info target not-p y
))
942 (define-vop (fast-conditional/unsigned fast-conditional
)
943 (:args
(x :scs
(unsigned-reg)
944 :load-if
(not (and (sc-is x unsigned-stack
)
945 (sc-is y unsigned-reg
))))
946 (y :scs
(unsigned-reg unsigned-stack
)))
947 (:arg-types unsigned-num unsigned-num
)
948 (:note
"inline (unsigned-byte 32) comparison"))
950 (define-vop (fast-conditional-c/unsigned fast-conditional
/unsigned
)
951 (:args
(x :scs
(unsigned-reg unsigned-stack
)))
952 (:arg-types unsigned-num
(:constant
(unsigned-byte 32)))
953 (:info target not-p y
))
956 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned
)
959 (lambda (suffix cost signed
)
960 `(define-vop (;; FIXME: These could be done more
961 ;; cleanly with SYMBOLICATE.
962 ,(intern (format nil
"~:@(FAST-IF-~A~A~)"
965 (format nil
"~:@(FAST-CONDITIONAL~A~)"
970 ,(if (eq suffix
'-c
/fixnum
)
981 '(/fixnum -c
/fixnum
/signed -c
/signed
/unsigned -c
/unsigned
)
983 '(t t t t nil nil
)))))
985 (define-conditional-vop < :l
:b
:ge
:ae
)
986 (define-conditional-vop > :g
:a
:le
:be
))
988 (define-vop (fast-if-eql/signed fast-conditional
/signed
)
992 (inst jmp
(if not-p
:ne
:e
) target
)))
994 (define-vop (fast-if-eql-c/signed fast-conditional-c
/signed
)
997 (cond ((and (sc-is x signed-reg
) (zerop y
))
998 (inst test x x
)) ; smaller instruction
1001 (inst jmp
(if not-p
:ne
:e
) target
)))
1003 (define-vop (fast-if-eql/unsigned fast-conditional
/unsigned
)
1007 (inst jmp
(if not-p
:ne
:e
) target
)))
1009 (define-vop (fast-if-eql-c/unsigned fast-conditional-c
/unsigned
)
1012 (cond ((and (sc-is x unsigned-reg
) (zerop y
))
1013 (inst test x x
)) ; smaller instruction
1016 (inst jmp
(if not-p
:ne
:e
) target
)))
1018 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
1021 ;;; These versions specify a fixnum restriction on their first arg. We have
1022 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
1023 ;;; the first arg and a higher cost. The reason for doing this is to prevent
1024 ;;; fixnum specific operations from being used on word integers, spuriously
1025 ;;; consing the argument.
1027 (define-vop (fast-eql/fixnum fast-conditional
)
1028 (:args
(x :scs
(any-reg)
1029 :load-if
(not (and (sc-is x control-stack
)
1030 (sc-is y any-reg
))))
1031 (y :scs
(any-reg control-stack
)))
1032 (:arg-types tagged-num tagged-num
)
1033 (:note
"inline fixnum comparison")
1037 (inst jmp
(if not-p
:ne
:e
) target
)))
1038 (define-vop (generic-eql/fixnum fast-eql
/fixnum
)
1039 (:args
(x :scs
(any-reg descriptor-reg
)
1040 :load-if
(not (and (sc-is x control-stack
)
1041 (sc-is y any-reg
))))
1042 (y :scs
(any-reg control-stack
)))
1043 (:arg-types
* tagged-num
)
1046 (define-vop (fast-eql-c/fixnum fast-conditional
/fixnum
)
1047 (:args
(x :scs
(any-reg control-stack
)))
1048 (:arg-types tagged-num
(:constant
(signed-byte 30)))
1049 (:info target not-p y
)
1052 (cond ((and (sc-is x any-reg
) (zerop y
))
1053 (inst test x x
)) ; smaller instruction
1055 (inst cmp x
(fixnumize y
))))
1056 (inst jmp
(if not-p
:ne
:e
) target
)))
1057 (define-vop (generic-eql-c/fixnum fast-eql-c
/fixnum
)
1058 (:args
(x :scs
(any-reg descriptor-reg control-stack
)))
1059 (:arg-types
* (:constant
(signed-byte 30)))
1062 ;;;; 32-bit logical operations
1064 (define-vop (merge-bits)
1065 (:translate merge-bits
)
1066 (:args
(shift :scs
(signed-reg unsigned-reg
) :target ecx
)
1067 (prev :scs
(unsigned-reg) :target result
)
1068 (next :scs
(unsigned-reg)))
1069 (:arg-types tagged-num unsigned-num unsigned-num
)
1070 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
0)) ecx
)
1071 (:results
(result :scs
(unsigned-reg) :from
(:argument
1)))
1072 (:result-types unsigned-num
)
1073 (:policy
:fast-safe
)
1077 (inst shrd result next
:cl
)))
1079 (define-source-transform 32bit-logical-not
(x)
1080 `(logand (lognot (the (unsigned-byte 32) ,x
)) #.
(1- (ash 1 32))))
1082 (deftransform 32bit-logical-and
((x y
))
1085 (define-source-transform 32bit-logical-nand
(x y
)
1086 `(32bit-logical-not (32bit-logical-and ,x
,y
)))
1088 (deftransform 32bit-logical-or
((x y
))
1091 (define-source-transform 32bit-logical-nor
(x y
)
1092 `(32bit-logical-not (32bit-logical-or ,x
,y
)))
1094 (deftransform 32bit-logical-xor
((x y
))
1097 (define-source-transform 32bit-logical-eqv
(x y
)
1098 `(32bit-logical-not (32bit-logical-xor ,x
,y
)))
1100 (define-source-transform 32bit-logical-orc1
(x y
)
1101 `(32bit-logical-or (32bit-logical-not ,x
) ,y
))
1103 (define-source-transform 32bit-logical-orc2
(x y
)
1104 `(32bit-logical-or ,x
(32bit-logical-not ,y
)))
1106 (define-source-transform 32bit-logical-andc1
(x y
)
1107 `(32bit-logical-and (32bit-logical-not ,x
) ,y
))
1109 (define-source-transform 32bit-logical-andc2
(x y
)
1110 `(32bit-logical-and ,x
(32bit-logical-not ,y
)))
1112 ;;; Only the lower 5 bits of the shift amount are significant.
1113 (define-vop (shift-towards-someplace)
1114 (:policy
:fast-safe
)
1115 (:args
(num :scs
(unsigned-reg) :target r
)
1116 (amount :scs
(signed-reg) :target ecx
))
1117 (:arg-types unsigned-num tagged-num
)
1118 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
1119 (:results
(r :scs
(unsigned-reg) :from
(:argument
0)))
1120 (:result-types unsigned-num
))
1122 (define-vop (shift-towards-start shift-towards-someplace
)
1123 (:translate shift-towards-start
)
1124 (:note
"SHIFT-TOWARDS-START")
1130 (define-vop (shift-towards-end shift-towards-someplace
)
1131 (:translate shift-towards-end
)
1132 (:note
"SHIFT-TOWARDS-END")
1138 ;;;; Modular functions
1140 (define-modular-fun +-mod32
(x y
) + 32)
1141 (define-vop (fast-+-mod32
/unsigned
=>unsigned fast-
+/unsigned
=>unsigned
)
1142 (:translate
+-mod32
))
1143 (define-vop (fast-+-mod32-c
/unsigned
=>unsigned fast-
+-c
/unsigned
=>unsigned
)
1144 (:translate
+-mod32
))
1145 (define-modular-fun --mod32
(x y
) -
32)
1146 (define-vop (fast---mod32/unsigned
=>unsigned fast--
/unsigned
=>unsigned
)
1147 (:translate --mod32
))
1148 (define-vop (fast---mod32-c/unsigned
=>unsigned fast---c
/unsigned
=>unsigned
)
1149 (:translate --mod32
))
1151 (define-vop (fast-ash-left-mod32-c/unsigned
=>unsigned
1152 fast-ash-c
/unsigned
=>unsigned
)
1153 (:translate ash-left-mod32
))
1155 ;;; logical operations
1156 (define-modular-fun lognot-mod32
(x) lognot
32)
1157 (define-vop (lognot-mod32/unsigned
=>unsigned
)
1158 (:translate lognot-mod32
)
1159 (:args
(x :scs
(unsigned-reg unsigned-stack
) :target r
1160 :load-if
(not (and (sc-is x unsigned-stack
)
1161 (sc-is r unsigned-stack
)
1163 (:arg-types unsigned-num
)
1164 (:results
(r :scs
(unsigned-reg)
1165 :load-if
(not (and (sc-is x unsigned-stack
)
1166 (sc-is r unsigned-stack
)
1168 (:result-types unsigned-num
)
1169 (:policy
:fast-safe
)
1174 (define-modular-fun logxor-mod32
(x y
) logxor
32)
1175 (define-vop (fast-logxor-mod32/unsigned
=>unsigned
1176 fast-logxor
/unsigned
=>unsigned
)
1177 (:translate logxor-mod32
))
1178 (define-vop (fast-logxor-mod32-c/unsigned
=>unsigned
1179 fast-logxor-c
/unsigned
=>unsigned
)
1180 (:translate logxor-mod32
))
1182 (define-source-transform logeqv
(&rest args
)
1183 (if (oddp (length args
))
1185 `(lognot (logxor ,@args
))))
1186 (define-source-transform logandc1
(x y
)
1187 `(logand (lognot ,x
) ,y
))
1188 (define-source-transform logandc2
(x y
)
1189 `(logand ,x
(lognot ,y
)))
1190 (define-source-transform logorc1
(x y
)
1191 `(logior (lognot ,x
) ,y
))
1192 (define-source-transform logorc2
(x y
)
1193 `(logior ,x
(lognot ,y
)))
1194 (define-source-transform lognor
(x y
)
1195 `(lognot (logior ,x
,y
)))
1196 (define-source-transform lognand
(x y
)
1197 `(lognot (logand ,x
,y
)))
1201 (define-vop (bignum-length get-header-data
)
1202 (:translate sb
!bignum
::%bignum-length
)
1203 (:policy
:fast-safe
))
1205 (define-vop (bignum-set-length set-header-data
)
1206 (:translate sb
!bignum
::%bignum-set-length
)
1207 (:policy
:fast-safe
))
1209 (define-full-reffer bignum-ref
* bignum-digits-offset other-pointer-lowtag
1210 (unsigned-reg) unsigned-num sb
!bignum
::%bignum-ref
)
1212 (define-full-setter bignum-set
* bignum-digits-offset other-pointer-lowtag
1213 (unsigned-reg) unsigned-num sb
!bignum
::%bignum-set
)
1215 (define-vop (digit-0-or-plus)
1216 (:translate sb
!bignum
::%digit-0-or-plusp
)
1217 (:policy
:fast-safe
)
1218 (:args
(digit :scs
(unsigned-reg)))
1219 (:arg-types unsigned-num
)
1221 (:info target not-p
)
1223 (inst or digit digit
)
1224 (inst jmp
(if not-p
:s
:ns
) target
)))
1227 ;;; For add and sub with carry the sc of carry argument is any-reg so
1228 ;;; the it may be passed as a fixnum or word and thus may be 0, 1, or
1229 ;;; 4. This is easy to deal with and may save a fixnum-word
1231 (define-vop (add-w/carry
)
1232 (:translate sb
!bignum
::%add-with-carry
)
1233 (:policy
:fast-safe
)
1234 (:args
(a :scs
(unsigned-reg) :target result
)
1235 (b :scs
(unsigned-reg unsigned-stack
) :to
:eval
)
1236 (c :scs
(any-reg) :target temp
))
1237 (:arg-types unsigned-num unsigned-num positive-fixnum
)
1238 (:temporary
(:sc any-reg
:from
(:argument
2) :to
:eval
) temp
)
1239 (:results
(result :scs
(unsigned-reg) :from
(:argument
0))
1240 (carry :scs
(unsigned-reg)))
1241 (:result-types unsigned-num positive-fixnum
)
1245 (inst neg temp
) ; Set the carry flag to 0 if c=0 else to 1
1248 (inst adc carry carry
)))
1250 ;;; Note: the borrow is the oppostite of the x86 convention - 1 for no
1251 ;;; borrow and 0 for a borrow.
1252 (define-vop (sub-w/borrow
)
1253 (:translate sb
!bignum
::%subtract-with-borrow
)
1254 (:policy
:fast-safe
)
1255 (:args
(a :scs
(unsigned-reg) :to
:eval
:target result
)
1256 (b :scs
(unsigned-reg unsigned-stack
) :to
:result
)
1257 (c :scs
(any-reg control-stack
)))
1258 (:arg-types unsigned-num unsigned-num positive-fixnum
)
1259 (:results
(result :scs
(unsigned-reg) :from
:eval
)
1260 (borrow :scs
(unsigned-reg)))
1261 (:result-types unsigned-num positive-fixnum
)
1263 (inst cmp c
1) ; Set the carry flag to 1 if c=0 else to 0
1267 (inst adc borrow borrow
)
1268 (inst xor borrow
1)))
1271 (define-vop (bignum-mult-and-add-3-arg)
1272 (:translate sb
!bignum
::%multiply-and-add
)
1273 (:policy
:fast-safe
)
1274 (:args
(x :scs
(unsigned-reg) :target eax
)
1275 (y :scs
(unsigned-reg unsigned-stack
))
1276 (carry-in :scs
(unsigned-reg unsigned-stack
)))
1277 (:arg-types unsigned-num unsigned-num unsigned-num
)
1278 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0)
1279 :to
(:result
1) :target lo
) eax
)
1280 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
1)
1281 :to
(:result
0) :target hi
) edx
)
1282 (:results
(hi :scs
(unsigned-reg))
1283 (lo :scs
(unsigned-reg)))
1284 (:result-types unsigned-num unsigned-num
)
1288 (inst add eax carry-in
)
1293 (define-vop (bignum-mult-and-add-4-arg)
1294 (:translate sb
!bignum
::%multiply-and-add
)
1295 (:policy
:fast-safe
)
1296 (:args
(x :scs
(unsigned-reg) :target eax
)
1297 (y :scs
(unsigned-reg unsigned-stack
))
1298 (prev :scs
(unsigned-reg unsigned-stack
))
1299 (carry-in :scs
(unsigned-reg unsigned-stack
)))
1300 (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num
)
1301 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0)
1302 :to
(:result
1) :target lo
) eax
)
1303 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
1)
1304 :to
(:result
0) :target hi
) edx
)
1305 (:results
(hi :scs
(unsigned-reg))
1306 (lo :scs
(unsigned-reg)))
1307 (:result-types unsigned-num unsigned-num
)
1313 (inst add eax carry-in
)
1319 (define-vop (bignum-mult)
1320 (:translate sb
!bignum
::%multiply
)
1321 (:policy
:fast-safe
)
1322 (:args
(x :scs
(unsigned-reg) :target eax
)
1323 (y :scs
(unsigned-reg unsigned-stack
)))
1324 (:arg-types unsigned-num unsigned-num
)
1325 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0)
1326 :to
(:result
1) :target lo
) eax
)
1327 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
1)
1328 :to
(:result
0) :target hi
) edx
)
1329 (:results
(hi :scs
(unsigned-reg))
1330 (lo :scs
(unsigned-reg)))
1331 (:result-types unsigned-num unsigned-num
)
1338 (define-vop (bignum-lognot lognot-mod32
/unsigned
=>unsigned
)
1339 (:translate sb
!bignum
::%lognot
))
1341 (define-vop (fixnum-to-digit)
1342 (:translate sb
!bignum
::%fixnum-to-digit
)
1343 (:policy
:fast-safe
)
1344 (:args
(fixnum :scs
(any-reg control-stack
) :target digit
))
1345 (:arg-types tagged-num
)
1346 (:results
(digit :scs
(unsigned-reg)
1347 :load-if
(not (and (sc-is fixnum control-stack
)
1348 (sc-is digit unsigned-stack
)
1349 (location= fixnum digit
)))))
1350 (:result-types unsigned-num
)
1353 (inst sar digit
2)))
1355 (define-vop (bignum-floor)
1356 (:translate sb
!bignum
::%floor
)
1357 (:policy
:fast-safe
)
1358 (:args
(div-high :scs
(unsigned-reg) :target edx
)
1359 (div-low :scs
(unsigned-reg) :target eax
)
1360 (divisor :scs
(unsigned-reg unsigned-stack
)))
1361 (:arg-types unsigned-num unsigned-num unsigned-num
)
1362 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
1)
1363 :to
(:result
0) :target quo
) eax
)
1364 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
0)
1365 :to
(:result
1) :target rem
) edx
)
1366 (:results
(quo :scs
(unsigned-reg))
1367 (rem :scs
(unsigned-reg)))
1368 (:result-types unsigned-num unsigned-num
)
1372 (inst div eax divisor
)
1376 (define-vop (signify-digit)
1377 (:translate sb
!bignum
::%fixnum-digit-with-correct-sign
)
1378 (:policy
:fast-safe
)
1379 (:args
(digit :scs
(unsigned-reg unsigned-stack
) :target res
))
1380 (:arg-types unsigned-num
)
1381 (:results
(res :scs
(any-reg signed-reg
)
1382 :load-if
(not (and (sc-is digit unsigned-stack
)
1383 (sc-is res control-stack signed-stack
)
1384 (location= digit res
)))))
1385 (:result-types signed-num
)
1388 (when (sc-is res any-reg control-stack
)
1391 (define-vop (digit-ashr)
1392 (:translate sb
!bignum
::%ashr
)
1393 (:policy
:fast-safe
)
1394 (:args
(digit :scs
(unsigned-reg unsigned-stack
) :target result
)
1395 (count :scs
(unsigned-reg) :target ecx
))
1396 (:arg-types unsigned-num positive-fixnum
)
1397 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
1398 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)
1399 :load-if
(not (and (sc-is result unsigned-stack
)
1400 (location= digit result
)))))
1401 (:result-types unsigned-num
)
1405 (inst sar result
:cl
)))
1407 (define-vop (digit-lshr digit-ashr
)
1408 (:translate sb
!bignum
::%digit-logical-shift-right
)
1412 (inst shr result
:cl
)))
1414 (define-vop (digit-ashl digit-ashr
)
1415 (:translate sb
!bignum
::%ashl
)
1419 (inst shl result
:cl
)))
1421 ;;;; static functions
1423 (define-static-fun two-arg-
/ (x y
) :translate
/)
1425 (define-static-fun two-arg-gcd
(x y
) :translate gcd
)
1426 (define-static-fun two-arg-lcm
(x y
) :translate lcm
)
1428 (define-static-fun two-arg-and
(x y
) :translate logand
)
1429 (define-static-fun two-arg-ior
(x y
) :translate logior
)
1430 (define-static-fun two-arg-xor
(x y
) :translate logxor
)
1433 ;;; Support for the Mersenne Twister, MT19937, random number generator
1434 ;;; due to Matsumoto and Nishimura.
1436 ;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A
1437 ;;; 623-dimensionally equidistributed uniform pseudorandom number
1438 ;;; generator.", ACM Transactions on Modeling and Computer Simulation,
1439 ;;; 1997, to appear.
1442 ;;; 0-1: Constant matrix A. [0, #x9908b0df] (not used here)
1443 ;;; 2: Index; init. to 1.
1445 (defknown random-mt19937
((simple-array (unsigned-byte 32) (*)))
1446 (unsigned-byte 32) ())
1447 (define-vop (random-mt19937)
1448 (:policy
:fast-safe
)
1449 (:translate random-mt19937
)
1450 (:args
(state :scs
(descriptor-reg) :to
:result
))
1451 (:arg-types simple-array-unsigned-byte-32
)
1452 (:temporary
(:sc unsigned-reg
:from
(:eval
0) :to
:result
) k
)
1453 (:temporary
(:sc unsigned-reg
:offset eax-offset
1454 :from
(:eval
0) :to
:result
) tmp
)
1455 (:results
(y :scs
(unsigned-reg) :from
(:eval
0)))
1456 (:result-types unsigned-num
)
1458 (inst mov k
(make-ea :dword
:base state
1459 :disp
(- (* (+ 2 vector-data-offset
)
1461 other-pointer-lowtag
)))
1463 (inst jmp
:ne no-update
)
1464 (inst mov tmp state
) ; The state is passed in EAX.
1465 (inst call
(make-fixup 'random-mt19937-update
:assembly-routine
))
1466 ;; Restore k, and set to 0.
1470 (inst mov y
(make-ea :dword
:base state
:index k
:scale
4
1471 :disp
(- (* (+ 3 vector-data-offset
)
1473 other-pointer-lowtag
)))
1476 (inst xor y
(make-ea :dword
:base state
:index k
:scale
4
1477 :disp
(- (* (+ 3 vector-data-offset
)
1479 other-pointer-lowtag
)))
1480 ;; y ^= (y << 7) & #x9d2c5680
1484 (inst mov
(make-ea :dword
:base state
1485 :disp
(- (* (+ 2 vector-data-offset
)
1487 other-pointer-lowtag
))
1489 (inst and tmp
#x9d2c5680
)
1491 ;; y ^= (y << 15) & #xefc60000
1494 (inst and tmp
#xefc60000
)
1503 (defknown %lea
((or (signed-byte 32) (unsigned-byte 32))
1504 (or (signed-byte 32) (unsigned-byte 32))
1505 (member 1 2 4 8) (signed-byte 32))
1506 (or (signed-byte 32) (unsigned-byte 32))
1507 (foldable flushable
))
1509 (defoptimizer (%lea derive-type
) ((base index scale disp
))
1510 (when (and (constant-lvar-p scale
)
1511 (constant-lvar-p disp
))
1512 (let ((scale (lvar-value scale
))
1513 (disp (lvar-value disp
))
1514 (base-type (lvar-type base
))
1515 (index-type (lvar-type index
)))
1516 (when (and (numeric-type-p base-type
)
1517 (numeric-type-p index-type
))
1518 (let ((base-lo (numeric-type-low base-type
))
1519 (base-hi (numeric-type-high base-type
))
1520 (index-lo (numeric-type-low index-type
))
1521 (index-hi (numeric-type-high index-type
)))
1522 (make-numeric-type :class
'integer
1524 :low
(when (and base-lo index-lo
)
1525 (+ base-lo
(* index-lo scale
) disp
))
1526 :high
(when (and base-hi index-hi
)
1527 (+ base-hi
(* index-hi scale
) disp
))))))))
1529 (defun %lea
(base index scale disp
)
1530 (+ base
(* index scale
) disp
))
1532 (in-package "SB!VM")
1534 (define-vop (%lea
/unsigned
=>unsigned
)
1536 (:policy
:fast-safe
)
1537 (:args
(base :scs
(unsigned-reg))
1538 (index :scs
(unsigned-reg)))
1540 (:arg-types unsigned-num unsigned-num
1541 (:constant
(member 1 2 4 8))
1542 (:constant
(signed-byte 32)))
1543 (:results
(r :scs
(unsigned-reg)))
1544 (:result-types unsigned-num
)
1546 (inst lea r
(make-ea :dword
:base base
:index index
1547 :scale scale
:disp disp
))))
1549 (define-vop (%lea
/signed
=>signed
)
1551 (:policy
:fast-safe
)
1552 (:args
(base :scs
(signed-reg))
1553 (index :scs
(signed-reg)))
1555 (:arg-types signed-num signed-num
1556 (:constant
(member 1 2 4 8))
1557 (:constant
(signed-byte 32)))
1558 (:results
(r :scs
(signed-reg)))
1559 (:result-types signed-num
)
1561 (inst lea r
(make-ea :dword
:base base
:index index
1562 :scale scale
:disp disp
))))
1564 (define-vop (%lea
/fixnum
=>fixnum
)
1566 (:policy
:fast-safe
)
1567 (:args
(base :scs
(any-reg))
1568 (index :scs
(any-reg)))
1570 (:arg-types tagged-num tagged-num
1571 (:constant
(member 1 2 4 8))
1572 (:constant
(signed-byte 32)))
1573 (:results
(r :scs
(any-reg)))
1574 (:result-types tagged-num
)
1576 (inst lea r
(make-ea :dword
:base base
:index index
1577 :scale scale
:disp disp
))))
1581 ;;; This is essentially a straight implementation of the algorithm in
1582 ;;; "Strength Reduction of Multiplications by Integer Constants",
1583 ;;; Youfeng Wu, ACM SIGPLAN Notices, Vol. 30, No.2, February 1995.
1584 (defun basic-decompose-multiplication (arg num n-bits condensed
)
1585 (case (aref condensed
0)
1587 (let ((tmp (min 3 (aref condensed
1))))
1588 (decf (aref condensed
1) tmp
)
1591 ,(decompose-multiplication
1592 arg
(ash (1- num
) (- tmp
)) (1- n-bits
) (subseq condensed
1))
1595 (let ((r0 (aref condensed
0)))
1596 (incf (aref condensed
1) r0
)
1598 (%lea
,(decompose-multiplication
1599 arg
(- num
(ash 1 r0
)) (1- n-bits
) (subseq condensed
1))
1602 (t (let ((r0 (aref condensed
0)))
1603 (setf (aref condensed
0) 0)
1605 (ash ,(decompose-multiplication
1606 arg
(ash num
(- r0
)) n-bits condensed
)
1609 (defun decompose-multiplication (arg num n-bits condensed
)
1614 `(logand #xffffffff
(ash ,arg
,(1- (integer-length num
)))))
1615 ((let ((max 0) (end 0))
1616 (loop for i from
2 to
(length condensed
)
1617 for j
= (reduce #'+ (subseq condensed
0 i
))
1618 when
(and (> (- (* 2 i
) 3 j
) max
)
1619 (< (+ (ash 1 (1+ j
))
1620 (ash (ldb (byte (- 32 (1+ j
)) (1+ j
)) num
)
1623 do
(setq max
(- (* 2 i
) 3 j
)
1626 (let ((j (reduce #'+ (subseq condensed
0 end
))))
1627 (let ((n2 (+ (ash 1 (1+ j
))
1628 (ash (ldb (byte (- 32 (1+ j
)) (1+ j
)) num
) (1+ j
))))
1629 (n1 (1+ (ldb (byte (1+ j
) 0) (lognot num
)))))
1631 (- ,(optimize-multiply arg n2
) ,(optimize-multiply arg n1
))))))))
1632 ((dolist (i '(9 5 3))
1633 (when (integerp (/ num i
))
1634 (when (< (logcount (/ num i
)) (logcount num
))
1636 (return `(let ((,x
,(optimize-multiply arg
(/ num i
))))
1638 (%lea
,x
,x
(1- ,i
) 0)))))))))
1639 (t (basic-decompose-multiplication arg num n-bits condensed
))))
1641 (defun optimize-multiply (arg x
)
1642 (let* ((n-bits (logcount x
))
1643 (condensed (make-array n-bits
)))
1644 (let ((count 0) (bit 0))
1646 (cond ((logbitp i x
)
1647 (setf (aref condensed bit
) count
)
1651 (decompose-multiplication arg x n-bits condensed
)))
1653 (deftransform * ((x y
)
1654 ((unsigned-byte 32) (constant-arg (unsigned-byte 32)))
1656 "recode as leas, shifts and adds"
1657 (let ((y (lvar-value y
)))
1659 ((= y
(ash 1 (integer-length y
)))
1660 ;; there's a generic transform for y = 2^k
1661 (give-up-ir1-transform))
1662 ((member y
'(3 5 9))
1663 ;; we can do these multiplications directly using LEA
1664 `(%lea x x
,(1- y
) 0))
1665 ((member :pentium4
*backend-subfeatures
*)
1666 ;; the pentium4's multiply unit is reportedly very good
1667 (give-up-ir1-transform))
1668 ;; FIXME: should make this more fine-grained. If nothing else,
1669 ;; there should probably be a cutoff of about 9 instructions on
1670 ;; pentium-class machines.
1671 (t (optimize-multiply 'x y
)))))
1673 ;;; FIXME: we should also be able to write an optimizer or two to
1674 ;;; convert (+ (* x 2) 17), (- (* x 9) 5) to a %LEA.