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
))
188 ;;; Special handling of add on the x86; can use lea to avoid a
189 ;;; register load, otherwise it uses add.
190 (define-vop (fast-+/fixnum
=>fixnum fast-safe-arith-op
)
192 (:args
(x :scs
(any-reg) :target r
193 :load-if
(not (and (sc-is x control-stack
)
195 (sc-is r control-stack
)
197 (y :scs
(any-reg control-stack
)))
198 (:arg-types tagged-num tagged-num
)
199 (:results
(r :scs
(any-reg) :from
(:argument
0)
200 :load-if
(not (and (sc-is x control-stack
)
202 (sc-is r control-stack
)
204 (:result-types tagged-num
)
205 (:note
"inline fixnum arithmetic")
207 (cond ((and (sc-is x any-reg
) (sc-is y any-reg
) (sc-is r any-reg
)
208 (not (location= x r
)))
209 (inst lea r
(make-ea :dword
:base x
:index y
:scale
1)))
214 (define-vop (fast-+-c
/fixnum
=>fixnum fast-safe-arith-op
)
216 (:args
(x :target r
:scs
(any-reg control-stack
)))
218 (:arg-types tagged-num
(:constant
(signed-byte 30)))
219 (:results
(r :scs
(any-reg)
220 :load-if
(not (location= x r
))))
221 (:result-types tagged-num
)
222 (:note
"inline fixnum arithmetic")
224 (cond ((and (sc-is x any-reg
) (sc-is r any-reg
) (not (location= x r
)))
225 (inst lea r
(make-ea :dword
:base x
:disp
(fixnumize y
))))
228 (inst add r
(fixnumize y
))))))
230 (define-vop (fast-+/signed
=>signed fast-safe-arith-op
)
232 (:args
(x :scs
(signed-reg) :target r
233 :load-if
(not (and (sc-is x signed-stack
)
235 (sc-is r signed-stack
)
237 (y :scs
(signed-reg signed-stack
)))
238 (:arg-types signed-num signed-num
)
239 (:results
(r :scs
(signed-reg) :from
(:argument
0)
240 :load-if
(not (and (sc-is x signed-stack
)
243 (:result-types signed-num
)
244 (:note
"inline (signed-byte 32) arithmetic")
246 (cond ((and (sc-is x signed-reg
) (sc-is y signed-reg
) (sc-is r signed-reg
)
247 (not (location= x r
)))
248 (inst lea r
(make-ea :dword
:base x
:index y
:scale
1)))
254 ;;;; Special logand cases: (logand signed unsigned) => unsigned
256 (define-vop (fast-logand/signed-unsigned
=>unsigned
257 fast-logand
/unsigned
=>unsigned
)
258 (:args
(x :target r
:scs
(signed-reg)
259 :load-if
(not (and (sc-is x signed-stack
)
260 (sc-is y unsigned-reg
)
261 (sc-is r unsigned-stack
)
263 (y :scs
(unsigned-reg unsigned-stack
)))
264 (:arg-types signed-num unsigned-num
))
266 (define-vop (fast-logand-c/signed-unsigned
=>unsigned
267 fast-logand-c
/unsigned
=>unsigned
)
268 (:args
(x :target r
:scs
(signed-reg signed-stack
)))
269 (:arg-types signed-num
(:constant
(unsigned-byte 32))))
271 (define-vop (fast-logand/unsigned-signed
=>unsigned
272 fast-logand
/unsigned
=>unsigned
)
273 (:args
(x :target r
:scs
(unsigned-reg)
274 :load-if
(not (and (sc-is x unsigned-stack
)
276 (sc-is r unsigned-stack
)
278 (y :scs
(signed-reg signed-stack
)))
279 (:arg-types unsigned-num signed-num
))
282 (define-vop (fast-+-c
/signed
=>signed fast-safe-arith-op
)
284 (:args
(x :target r
:scs
(signed-reg signed-stack
)))
286 (:arg-types signed-num
(:constant
(signed-byte 32)))
287 (:results
(r :scs
(signed-reg)
288 :load-if
(not (location= x r
))))
289 (:result-types signed-num
)
290 (:note
"inline (signed-byte 32) arithmetic")
292 (cond ((and (sc-is x signed-reg
) (sc-is r signed-reg
)
293 (not (location= x r
)))
294 (inst lea r
(make-ea :dword
:base x
:disp y
)))
301 (define-vop (fast-+/unsigned
=>unsigned fast-safe-arith-op
)
303 (:args
(x :scs
(unsigned-reg) :target r
304 :load-if
(not (and (sc-is x unsigned-stack
)
305 (sc-is y unsigned-reg
)
306 (sc-is r unsigned-stack
)
308 (y :scs
(unsigned-reg unsigned-stack
)))
309 (:arg-types unsigned-num unsigned-num
)
310 (:results
(r :scs
(unsigned-reg) :from
(:argument
0)
311 :load-if
(not (and (sc-is x unsigned-stack
)
312 (sc-is y unsigned-reg
)
313 (sc-is r unsigned-stack
)
315 (:result-types unsigned-num
)
316 (:note
"inline (unsigned-byte 32) arithmetic")
318 (cond ((and (sc-is x unsigned-reg
) (sc-is y unsigned-reg
)
319 (sc-is r unsigned-reg
) (not (location= x r
)))
320 (inst lea r
(make-ea :dword
:base x
:index y
:scale
1)))
325 (define-vop (fast-+-c
/unsigned
=>unsigned fast-safe-arith-op
)
327 (:args
(x :target r
:scs
(unsigned-reg unsigned-stack
)))
329 (:arg-types unsigned-num
(:constant
(unsigned-byte 32)))
330 (:results
(r :scs
(unsigned-reg)
331 :load-if
(not (location= x r
))))
332 (:result-types unsigned-num
)
333 (:note
"inline (unsigned-byte 32) arithmetic")
335 (cond ((and (sc-is x unsigned-reg
) (sc-is r unsigned-reg
)
336 (not (location= x r
)))
337 (inst lea r
(make-ea :dword
:base x
:disp y
)))
344 ;;;; multiplication and division
346 (define-vop (fast-*/fixnum
=>fixnum fast-safe-arith-op
)
348 ;; We need different loading characteristics.
349 (:args
(x :scs
(any-reg) :target r
)
350 (y :scs
(any-reg control-stack
)))
351 (:arg-types tagged-num tagged-num
)
352 (:results
(r :scs
(any-reg) :from
(:argument
0)))
353 (:result-types tagged-num
)
354 (:note
"inline fixnum arithmetic")
360 (define-vop (fast-*-c
/fixnum
=>fixnum fast-safe-arith-op
)
362 ;; We need different loading characteristics.
363 (:args
(x :scs
(any-reg control-stack
)))
365 (:arg-types tagged-num
(:constant
(signed-byte 30)))
366 (:results
(r :scs
(any-reg)))
367 (:result-types tagged-num
)
368 (:note
"inline fixnum arithmetic")
372 (define-vop (fast-*/signed
=>signed fast-safe-arith-op
)
374 ;; We need different loading characteristics.
375 (:args
(x :scs
(signed-reg) :target r
)
376 (y :scs
(signed-reg signed-stack
)))
377 (:arg-types signed-num signed-num
)
378 (:results
(r :scs
(signed-reg) :from
(:argument
0)))
379 (:result-types signed-num
)
380 (:note
"inline (signed-byte 32) arithmetic")
385 (define-vop (fast-*-c
/signed
=>signed fast-safe-arith-op
)
387 ;; We need different loading characteristics.
388 (:args
(x :scs
(signed-reg signed-stack
)))
390 (:arg-types signed-num
(:constant
(signed-byte 32)))
391 (:results
(r :scs
(signed-reg)))
392 (:result-types signed-num
)
393 (:note
"inline (signed-byte 32) arithmetic")
397 (define-vop (fast-*/unsigned
=>unsigned fast-safe-arith-op
)
399 (:args
(x :scs
(unsigned-reg) :target eax
)
400 (y :scs
(unsigned-reg unsigned-stack
)))
401 (:arg-types unsigned-num unsigned-num
)
402 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target result
403 :from
(:argument
0) :to
:result
) eax
)
404 (:temporary
(:sc unsigned-reg
:offset edx-offset
405 :from
:eval
:to
:result
) edx
)
407 (:results
(result :scs
(unsigned-reg)))
408 (:result-types unsigned-num
)
409 (:note
"inline (unsigned-byte 32) arithmetic")
411 (:save-p
:compute-only
)
418 (define-vop (fast-truncate/fixnum
=>fixnum fast-safe-arith-op
)
419 (:translate truncate
)
420 (:args
(x :scs
(any-reg) :target eax
)
421 (y :scs
(any-reg control-stack
)))
422 (:arg-types tagged-num tagged-num
)
423 (:temporary
(:sc signed-reg
:offset eax-offset
:target quo
424 :from
(:argument
0) :to
(:result
0)) eax
)
425 (:temporary
(:sc unsigned-reg
:offset edx-offset
:target rem
426 :from
(:argument
0) :to
(:result
1)) edx
)
427 (:results
(quo :scs
(any-reg))
428 (rem :scs
(any-reg)))
429 (:result-types tagged-num tagged-num
)
430 (:note
"inline fixnum arithmetic")
432 (:save-p
:compute-only
)
434 (let ((zero (generate-error-code vop division-by-zero-error x y
)))
435 (if (sc-is y any-reg
)
436 (inst test y y
) ; smaller instruction
442 (if (location= quo eax
)
444 (inst lea quo
(make-ea :dword
:index eax
:scale
4)))
447 (define-vop (fast-truncate-c/fixnum
=>fixnum fast-safe-arith-op
)
448 (:translate truncate
)
449 (:args
(x :scs
(any-reg) :target eax
))
451 (:arg-types tagged-num
(:constant
(signed-byte 30)))
452 (:temporary
(:sc signed-reg
:offset eax-offset
:target quo
453 :from
:argument
:to
(:result
0)) eax
)
454 (:temporary
(:sc any-reg
:offset edx-offset
:target rem
455 :from
:eval
:to
(:result
1)) edx
)
456 (:temporary
(:sc any-reg
:from
:eval
:to
:result
) y-arg
)
457 (:results
(quo :scs
(any-reg))
458 (rem :scs
(any-reg)))
459 (:result-types tagged-num tagged-num
)
460 (:note
"inline fixnum arithmetic")
462 (:save-p
:compute-only
)
466 (inst mov y-arg
(fixnumize y
))
467 (inst idiv eax y-arg
)
468 (if (location= quo eax
)
470 (inst lea quo
(make-ea :dword
:index eax
:scale
4)))
473 (define-vop (fast-truncate/unsigned
=>unsigned fast-safe-arith-op
)
474 (:translate truncate
)
475 (:args
(x :scs
(unsigned-reg) :target eax
)
476 (y :scs
(unsigned-reg signed-stack
)))
477 (:arg-types unsigned-num unsigned-num
)
478 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target quo
479 :from
(:argument
0) :to
(:result
0)) eax
)
480 (:temporary
(:sc unsigned-reg
:offset edx-offset
:target rem
481 :from
(:argument
0) :to
(:result
1)) edx
)
482 (:results
(quo :scs
(unsigned-reg))
483 (rem :scs
(unsigned-reg)))
484 (:result-types unsigned-num unsigned-num
)
485 (:note
"inline (unsigned-byte 32) arithmetic")
487 (:save-p
:compute-only
)
489 (let ((zero (generate-error-code vop division-by-zero-error x y
)))
490 (if (sc-is y unsigned-reg
)
491 (inst test y y
) ; smaller instruction
500 (define-vop (fast-truncate-c/unsigned
=>unsigned fast-safe-arith-op
)
501 (:translate truncate
)
502 (:args
(x :scs
(unsigned-reg) :target eax
))
504 (:arg-types unsigned-num
(:constant
(unsigned-byte 32)))
505 (:temporary
(:sc unsigned-reg
:offset eax-offset
:target quo
506 :from
:argument
:to
(:result
0)) eax
)
507 (:temporary
(:sc unsigned-reg
:offset edx-offset
:target rem
508 :from
:eval
:to
(:result
1)) edx
)
509 (:temporary
(:sc unsigned-reg
:from
:eval
:to
:result
) y-arg
)
510 (:results
(quo :scs
(unsigned-reg))
511 (rem :scs
(unsigned-reg)))
512 (:result-types unsigned-num unsigned-num
)
513 (:note
"inline (unsigned-byte 32) arithmetic")
515 (:save-p
:compute-only
)
524 (define-vop (fast-truncate/signed
=>signed fast-safe-arith-op
)
525 (:translate truncate
)
526 (:args
(x :scs
(signed-reg) :target eax
)
527 (y :scs
(signed-reg signed-stack
)))
528 (:arg-types signed-num signed-num
)
529 (:temporary
(:sc signed-reg
:offset eax-offset
:target quo
530 :from
(:argument
0) :to
(:result
0)) eax
)
531 (:temporary
(:sc signed-reg
:offset edx-offset
:target rem
532 :from
(:argument
0) :to
(:result
1)) edx
)
533 (:results
(quo :scs
(signed-reg))
534 (rem :scs
(signed-reg)))
535 (:result-types signed-num signed-num
)
536 (:note
"inline (signed-byte 32) arithmetic")
538 (:save-p
:compute-only
)
540 (let ((zero (generate-error-code vop division-by-zero-error x y
)))
541 (if (sc-is y signed-reg
)
542 (inst test y y
) ; smaller instruction
551 (define-vop (fast-truncate-c/signed
=>signed fast-safe-arith-op
)
552 (:translate truncate
)
553 (:args
(x :scs
(signed-reg) :target eax
))
555 (:arg-types signed-num
(:constant
(signed-byte 32)))
556 (:temporary
(:sc signed-reg
:offset eax-offset
:target quo
557 :from
:argument
:to
(:result
0)) eax
)
558 (:temporary
(:sc signed-reg
:offset edx-offset
:target rem
559 :from
:eval
:to
(:result
1)) edx
)
560 (:temporary
(:sc signed-reg
:from
:eval
:to
:result
) y-arg
)
561 (:results
(quo :scs
(signed-reg))
562 (rem :scs
(signed-reg)))
563 (:result-types signed-num signed-num
)
564 (:note
"inline (signed-byte 32) arithmetic")
566 (:save-p
:compute-only
)
571 (inst idiv eax y-arg
)
578 (define-vop (fast-ash-c/fixnum
=>fixnum
)
581 (:args
(number :scs
(any-reg) :target result
582 :load-if
(not (and (sc-is number any-reg control-stack
)
583 (sc-is result any-reg control-stack
)
584 (location= number result
)))))
586 (:arg-types tagged-num
(:constant integer
))
587 (:results
(result :scs
(any-reg)
588 :load-if
(not (and (sc-is number control-stack
)
589 (sc-is result control-stack
)
590 (location= number result
)))))
591 (:result-types tagged-num
)
594 (cond ((and (= amount
1) (not (location= number result
)))
595 (inst lea result
(make-ea :dword
:index number
:scale
2)))
596 ((and (= amount
2) (not (location= number result
)))
597 (inst lea result
(make-ea :dword
:index number
:scale
4)))
598 ((and (= amount
3) (not (location= number result
)))
599 (inst lea result
(make-ea :dword
:index number
:scale
8)))
602 (cond ((plusp amount
)
603 ;; We don't have to worry about overflow because of the
604 ;; result type restriction.
605 (inst shl result amount
))
607 ;; If the amount is greater than 31, only shift by 31. We
608 ;; have to do this because the shift instructions only look
609 ;; at the low five bits of the result.
610 (inst sar result
(min 31 (- amount
)))
611 ;; Fixnum correction.
612 (inst and result
#xfffffffc
)))))))
614 (define-vop (fast-ash-left/fixnum
=>fixnum
)
616 (:args
(number :scs
(any-reg) :target result
617 :load-if
(not (and (sc-is number control-stack
)
618 (sc-is result control-stack
)
619 (location= number result
))))
620 (amount :scs
(unsigned-reg) :target ecx
))
621 (:arg-types tagged-num positive-fixnum
)
622 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
623 (:results
(result :scs
(any-reg) :from
(:argument
0)
624 :load-if
(not (and (sc-is number control-stack
)
625 (sc-is result control-stack
)
626 (location= number result
)))))
627 (:result-types tagged-num
)
633 ;; The result-type ensures us that this shift will not overflow.
634 (inst shl result
:cl
)))
636 (define-vop (fast-ash-c/signed
=>signed
)
639 (:args
(number :scs
(signed-reg) :target result
640 :load-if
(not (and (sc-is number signed-stack
)
641 (sc-is result signed-stack
)
642 (location= number result
)))))
644 (:arg-types signed-num
(:constant integer
))
645 (:results
(result :scs
(signed-reg)
646 :load-if
(not (and (sc-is number signed-stack
)
647 (sc-is result signed-stack
)
648 (location= number result
)))))
649 (:result-types signed-num
)
652 (cond ((and (= amount
1) (not (location= number result
)))
653 (inst lea result
(make-ea :dword
:index number
:scale
2)))
654 ((and (= amount
2) (not (location= number result
)))
655 (inst lea result
(make-ea :dword
:index number
:scale
4)))
656 ((and (= amount
3) (not (location= number result
)))
657 (inst lea result
(make-ea :dword
:index number
:scale
8)))
660 (cond ((plusp amount
) (inst shl result amount
))
661 (t (inst sar result
(min 31 (- amount
)))))))))
663 (define-vop (fast-ash-c/unsigned
=>unsigned
)
666 (:args
(number :scs
(unsigned-reg) :target result
667 :load-if
(not (and (sc-is number unsigned-stack
)
668 (sc-is result unsigned-stack
)
669 (location= number result
)))))
671 (:arg-types unsigned-num
(:constant integer
))
672 (:results
(result :scs
(unsigned-reg)
673 :load-if
(not (and (sc-is number unsigned-stack
)
674 (sc-is result unsigned-stack
)
675 (location= number result
)))))
676 (:result-types unsigned-num
)
679 (cond ((and (= amount
1) (not (location= number result
)))
680 (inst lea result
(make-ea :dword
:index number
:scale
2)))
681 ((and (= amount
2) (not (location= number result
)))
682 (inst lea result
(make-ea :dword
:index number
:scale
4)))
683 ((and (= amount
3) (not (location= number result
)))
684 (inst lea result
(make-ea :dword
:index number
:scale
8)))
687 (cond ((plusp amount
) (inst shl result amount
))
688 ((< amount -
31) (inst xor result result
))
689 (t (inst shr result
(- amount
))))))))
691 (define-vop (fast-ash-left/signed
)
693 (:args
(number :scs
(signed-reg) :target result
694 :load-if
(not (and (sc-is number signed-stack
)
695 (sc-is result signed-stack
)
696 (location= number result
))))
697 (amount :scs
(unsigned-reg) :target ecx
))
698 (:arg-types signed-num positive-fixnum
)
699 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
700 (:results
(result :scs
(signed-reg) :from
(:argument
0)
701 :load-if
(not (and (sc-is number signed-stack
)
702 (sc-is result signed-stack
)
703 (location= number result
)))))
704 (:result-types signed-num
)
710 (inst shl result
:cl
)))
712 (define-vop (fast-ash-left/unsigned
)
714 (:args
(number :scs
(unsigned-reg) :target result
715 :load-if
(not (and (sc-is number unsigned-stack
)
716 (sc-is result unsigned-stack
)
717 (location= number result
))))
718 (amount :scs
(unsigned-reg) :target ecx
))
719 (:arg-types unsigned-num positive-fixnum
)
720 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
721 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)
722 :load-if
(not (and (sc-is number unsigned-stack
)
723 (sc-is result unsigned-stack
)
724 (location= number result
)))))
725 (:result-types unsigned-num
)
731 (inst shl result
:cl
)))
733 (define-vop (fast-ash/signed
=>signed
)
736 (:args
(number :scs
(signed-reg) :target result
)
737 (amount :scs
(signed-reg) :target ecx
))
738 (:arg-types signed-num signed-num
)
739 (:results
(result :scs
(signed-reg) :from
(:argument
0)))
740 (:result-types signed-num
)
741 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
747 (inst jmp
:ns positive
)
753 (inst sar result
:cl
)
757 ;; The result-type ensures us that this shift will not overflow.
758 (inst shl result
:cl
)
762 (define-vop (fast-ash/unsigned
=>unsigned
)
765 (:args
(number :scs
(unsigned-reg) :target result
)
766 (amount :scs
(signed-reg) :target ecx
))
767 (:arg-types unsigned-num signed-num
)
768 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)))
769 (:result-types unsigned-num
)
770 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
776 (inst jmp
:ns positive
)
780 (inst xor result result
)
783 (inst shr result
:cl
)
787 ;; The result-type ensures us that this shift will not overflow.
788 (inst shl result
:cl
)
792 ;;; Note: documentation for this function is wrong - rtfm
793 (define-vop (signed-byte-32-len)
794 (:translate integer-length
)
795 (:note
"inline (signed-byte 32) integer-length")
797 (:args
(arg :scs
(signed-reg) :target res
))
798 (:arg-types signed-num
)
799 (:results
(res :scs
(unsigned-reg)))
800 (:result-types unsigned-num
)
815 (define-vop (unsigned-byte-32-len)
816 (:translate integer-length
)
817 (:note
"inline (unsigned-byte 32) integer-length")
819 (:args
(arg :scs
(unsigned-reg)))
820 (:arg-types unsigned-num
)
821 (:results
(res :scs
(unsigned-reg)))
822 (:result-types unsigned-num
)
832 (define-vop (unsigned-byte-32-count)
833 (:translate logcount
)
834 (:note
"inline (unsigned-byte 32) logcount")
836 (:args
(arg :scs
(unsigned-reg)))
837 (:arg-types unsigned-num
)
838 (:results
(result :scs
(unsigned-reg)))
839 (:result-types positive-fixnum
)
840 (:temporary
(:sc unsigned-reg
:from
(:argument
0)) temp
)
844 (inst mov temp result
)
846 (inst and result
#x55555555
)
847 (inst and temp
#x55555555
)
848 (inst add result temp
)
850 (inst mov temp result
)
852 (inst and result
#x33333333
)
853 (inst and temp
#x33333333
)
854 (inst add result temp
)
856 (inst mov temp result
)
858 (inst and result
#x0f0f0f0f
)
859 (inst and temp
#x0f0f0f0f
)
860 (inst add result temp
)
862 (inst mov temp result
)
864 (inst and result
#x00ff00ff
)
865 (inst and temp
#x00ff00ff
)
866 (inst add result temp
)
868 (inst mov temp result
)
870 (inst and result
#x0000ffff
)
871 (inst and temp
#x0000ffff
)
872 (inst add result temp
)))
874 ;;;; binary conditional VOPs
876 (define-vop (fast-conditional)
881 (:policy
:fast-safe
))
883 (define-vop (fast-conditional/fixnum fast-conditional
)
884 (:args
(x :scs
(any-reg)
885 :load-if
(not (and (sc-is x control-stack
)
887 (y :scs
(any-reg control-stack
)))
888 (:arg-types tagged-num tagged-num
)
889 (:note
"inline fixnum comparison"))
891 (define-vop (fast-conditional-c/fixnum fast-conditional
/fixnum
)
892 (:args
(x :scs
(any-reg control-stack
)))
893 (:arg-types tagged-num
(:constant
(signed-byte 30)))
894 (:info target not-p y
))
896 (define-vop (fast-conditional/signed fast-conditional
)
897 (:args
(x :scs
(signed-reg)
898 :load-if
(not (and (sc-is x signed-stack
)
899 (sc-is y signed-reg
))))
900 (y :scs
(signed-reg signed-stack
)))
901 (:arg-types signed-num signed-num
)
902 (:note
"inline (signed-byte 32) comparison"))
904 (define-vop (fast-conditional-c/signed fast-conditional
/signed
)
905 (:args
(x :scs
(signed-reg signed-stack
)))
906 (:arg-types signed-num
(:constant
(signed-byte 32)))
907 (:info target not-p y
))
909 (define-vop (fast-conditional/unsigned fast-conditional
)
910 (:args
(x :scs
(unsigned-reg)
911 :load-if
(not (and (sc-is x unsigned-stack
)
912 (sc-is y unsigned-reg
))))
913 (y :scs
(unsigned-reg unsigned-stack
)))
914 (:arg-types unsigned-num unsigned-num
)
915 (:note
"inline (unsigned-byte 32) comparison"))
917 (define-vop (fast-conditional-c/unsigned fast-conditional
/unsigned
)
918 (:args
(x :scs
(unsigned-reg unsigned-stack
)))
919 (:arg-types unsigned-num
(:constant
(unsigned-byte 32)))
920 (:info target not-p y
))
923 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned
)
926 (lambda (suffix cost signed
)
927 `(define-vop (;; FIXME: These could be done more
928 ;; cleanly with SYMBOLICATE.
929 ,(intern (format nil
"~:@(FAST-IF-~A~A~)"
932 (format nil
"~:@(FAST-CONDITIONAL~A~)"
937 ,(if (eq suffix
'-c
/fixnum
)
948 '(/fixnum -c
/fixnum
/signed -c
/signed
/unsigned -c
/unsigned
)
950 '(t t t t nil nil
)))))
952 (define-conditional-vop < :l
:b
:ge
:ae
)
953 (define-conditional-vop > :g
:a
:le
:be
))
955 (define-vop (fast-if-eql/signed fast-conditional
/signed
)
959 (inst jmp
(if not-p
:ne
:e
) target
)))
961 (define-vop (fast-if-eql-c/signed fast-conditional-c
/signed
)
964 (cond ((and (sc-is x signed-reg
) (zerop y
))
965 (inst test x x
)) ; smaller instruction
968 (inst jmp
(if not-p
:ne
:e
) target
)))
970 (define-vop (fast-if-eql/unsigned fast-conditional
/unsigned
)
974 (inst jmp
(if not-p
:ne
:e
) target
)))
976 (define-vop (fast-if-eql-c/unsigned fast-conditional-c
/unsigned
)
979 (cond ((and (sc-is x unsigned-reg
) (zerop y
))
980 (inst test x x
)) ; smaller instruction
983 (inst jmp
(if not-p
:ne
:e
) target
)))
985 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
988 ;;; These versions specify a fixnum restriction on their first arg. We have
989 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
990 ;;; the first arg and a higher cost. The reason for doing this is to prevent
991 ;;; fixnum specific operations from being used on word integers, spuriously
992 ;;; consing the argument.
994 (define-vop (fast-eql/fixnum fast-conditional
)
995 (:args
(x :scs
(any-reg)
996 :load-if
(not (and (sc-is x control-stack
)
998 (y :scs
(any-reg control-stack
)))
999 (:arg-types tagged-num tagged-num
)
1000 (:note
"inline fixnum comparison")
1004 (inst jmp
(if not-p
:ne
:e
) target
)))
1005 (define-vop (generic-eql/fixnum fast-eql
/fixnum
)
1006 (:args
(x :scs
(any-reg descriptor-reg
)
1007 :load-if
(not (and (sc-is x control-stack
)
1008 (sc-is y any-reg
))))
1009 (y :scs
(any-reg control-stack
)))
1010 (:arg-types
* tagged-num
)
1013 (define-vop (fast-eql-c/fixnum fast-conditional
/fixnum
)
1014 (:args
(x :scs
(any-reg control-stack
)))
1015 (:arg-types tagged-num
(:constant
(signed-byte 30)))
1016 (:info target not-p y
)
1019 (cond ((and (sc-is x any-reg
) (zerop y
))
1020 (inst test x x
)) ; smaller instruction
1022 (inst cmp x
(fixnumize y
))))
1023 (inst jmp
(if not-p
:ne
:e
) target
)))
1024 (define-vop (generic-eql-c/fixnum fast-eql-c
/fixnum
)
1025 (:args
(x :scs
(any-reg descriptor-reg control-stack
)))
1026 (:arg-types
* (:constant
(signed-byte 30)))
1029 ;;;; 32-bit logical operations
1031 (define-vop (merge-bits)
1032 (:translate merge-bits
)
1033 (:args
(shift :scs
(signed-reg unsigned-reg
) :target ecx
)
1034 (prev :scs
(unsigned-reg) :target result
)
1035 (next :scs
(unsigned-reg)))
1036 (:arg-types tagged-num unsigned-num unsigned-num
)
1037 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
0)) ecx
)
1038 (:results
(result :scs
(unsigned-reg) :from
(:argument
1)))
1039 (:result-types unsigned-num
)
1040 (:policy
:fast-safe
)
1044 (inst shrd result next
:cl
)))
1046 (define-source-transform 32bit-logical-not
(x)
1047 `(logand (lognot (the (unsigned-byte 32) ,x
)) #.
(1- (ash 1 32))))
1049 (deftransform 32bit-logical-and
((x y
))
1052 (define-source-transform 32bit-logical-nand
(x y
)
1053 `(32bit-logical-not (32bit-logical-and ,x
,y
)))
1055 (deftransform 32bit-logical-or
((x y
))
1058 (define-source-transform 32bit-logical-nor
(x y
)
1059 `(32bit-logical-not (32bit-logical-or ,x
,y
)))
1061 (deftransform 32bit-logical-xor
((x y
))
1064 (define-source-transform 32bit-logical-eqv
(x y
)
1065 `(32bit-logical-not (32bit-logical-xor ,x
,y
)))
1067 (define-source-transform 32bit-logical-orc1
(x y
)
1068 `(32bit-logical-or (32bit-logical-not ,x
) ,y
))
1070 (define-source-transform 32bit-logical-orc2
(x y
)
1071 `(32bit-logical-or ,x
(32bit-logical-not ,y
)))
1073 (define-source-transform 32bit-logical-andc1
(x y
)
1074 `(32bit-logical-and (32bit-logical-not ,x
) ,y
))
1076 (define-source-transform 32bit-logical-andc2
(x y
)
1077 `(32bit-logical-and ,x
(32bit-logical-not ,y
)))
1079 ;;; Only the lower 5 bits of the shift amount are significant.
1080 (define-vop (shift-towards-someplace)
1081 (:policy
:fast-safe
)
1082 (:args
(num :scs
(unsigned-reg) :target r
)
1083 (amount :scs
(signed-reg) :target ecx
))
1084 (:arg-types unsigned-num tagged-num
)
1085 (:temporary
(:sc signed-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
1086 (:results
(r :scs
(unsigned-reg) :from
(:argument
0)))
1087 (:result-types unsigned-num
))
1089 (define-vop (shift-towards-start shift-towards-someplace
)
1090 (:translate shift-towards-start
)
1091 (:note
"SHIFT-TOWARDS-START")
1097 (define-vop (shift-towards-end shift-towards-someplace
)
1098 (:translate shift-towards-end
)
1099 (:note
"SHIFT-TOWARDS-END")
1105 ;;;; Modular functions
1107 (define-modular-fun +-mod32
(x y
) + 32)
1108 (define-vop (fast-+-mod32
/unsigned
=>unsigned fast-
+/unsigned
=>unsigned
)
1109 (:translate
+-mod32
))
1110 (define-vop (fast-+-mod32-c
/unsigned
=>unsigned fast-
+-c
/unsigned
=>unsigned
)
1111 (:translate
+-mod32
))
1113 ;;; logical operations
1114 (define-modular-fun lognot-mod32
(x) lognot
32)
1115 (define-vop (lognot-mod32/unsigned
=>unsigned
)
1116 (:translate lognot-mod32
)
1117 (:args
(x :scs
(unsigned-reg unsigned-stack
) :target r
1118 :load-if
(not (and (sc-is x unsigned-stack
)
1119 (sc-is r unsigned-stack
)
1121 (:arg-types unsigned-num
)
1122 (:results
(r :scs
(unsigned-reg)
1123 :load-if
(not (and (sc-is x unsigned-stack
)
1124 (sc-is r unsigned-stack
)
1126 (:result-types unsigned-num
)
1127 (:policy
:fast-safe
)
1132 (define-modular-fun logxor-mod32
(x y
) logxor
32)
1133 (define-vop (fast-logxor-mod32/unsigned
=>unsigned
1134 fast-logxor
/unsigned
=>unsigned
)
1135 (:translate logxor-mod32
))
1136 (define-vop (fast-logxor-mod32-c/unsigned
=>unsigned
1137 fast-logxor-c
/unsigned
=>unsigned
)
1138 (:translate logxor-mod32
))
1142 (define-vop (bignum-length get-header-data
)
1143 (:translate sb
!bignum
::%bignum-length
)
1144 (:policy
:fast-safe
))
1146 (define-vop (bignum-set-length set-header-data
)
1147 (:translate sb
!bignum
::%bignum-set-length
)
1148 (:policy
:fast-safe
))
1150 (define-full-reffer bignum-ref
* bignum-digits-offset other-pointer-lowtag
1151 (unsigned-reg) unsigned-num sb
!bignum
::%bignum-ref
)
1153 (define-full-setter bignum-set
* bignum-digits-offset other-pointer-lowtag
1154 (unsigned-reg) unsigned-num sb
!bignum
::%bignum-set
)
1156 (define-vop (digit-0-or-plus)
1157 (:translate sb
!bignum
::%digit-0-or-plusp
)
1158 (:policy
:fast-safe
)
1159 (:args
(digit :scs
(unsigned-reg)))
1160 (:arg-types unsigned-num
)
1162 (:info target not-p
)
1164 (inst or digit digit
)
1165 (inst jmp
(if not-p
:s
:ns
) target
)))
1168 ;;; For add and sub with carry the sc of carry argument is any-reg so
1169 ;;; the it may be passed as a fixnum or word and thus may be 0, 1, or
1170 ;;; 4. This is easy to deal with and may save a fixnum-word
1172 (define-vop (add-w/carry
)
1173 (:translate sb
!bignum
::%add-with-carry
)
1174 (:policy
:fast-safe
)
1175 (:args
(a :scs
(unsigned-reg) :target result
)
1176 (b :scs
(unsigned-reg unsigned-stack
) :to
:eval
)
1177 (c :scs
(any-reg) :target temp
))
1178 (:arg-types unsigned-num unsigned-num positive-fixnum
)
1179 (:temporary
(:sc any-reg
:from
(:argument
2) :to
:eval
) temp
)
1180 (:results
(result :scs
(unsigned-reg) :from
(:argument
0))
1181 (carry :scs
(unsigned-reg)))
1182 (:result-types unsigned-num positive-fixnum
)
1186 (inst neg temp
) ; Set the carry flag to 0 if c=0 else to 1
1189 (inst adc carry carry
)))
1191 ;;; Note: the borrow is the oppostite of the x86 convention - 1 for no
1192 ;;; borrow and 0 for a borrow.
1193 (define-vop (sub-w/borrow
)
1194 (:translate sb
!bignum
::%subtract-with-borrow
)
1195 (:policy
:fast-safe
)
1196 (:args
(a :scs
(unsigned-reg) :to
:eval
:target result
)
1197 (b :scs
(unsigned-reg unsigned-stack
) :to
:result
)
1198 (c :scs
(any-reg control-stack
)))
1199 (:arg-types unsigned-num unsigned-num positive-fixnum
)
1200 (:results
(result :scs
(unsigned-reg) :from
:eval
)
1201 (borrow :scs
(unsigned-reg)))
1202 (:result-types unsigned-num positive-fixnum
)
1204 (inst cmp c
1) ; Set the carry flag to 1 if c=0 else to 0
1208 (inst adc borrow borrow
)
1209 (inst xor borrow
1)))
1212 (define-vop (bignum-mult-and-add-3-arg)
1213 (:translate sb
!bignum
::%multiply-and-add
)
1214 (:policy
:fast-safe
)
1215 (:args
(x :scs
(unsigned-reg) :target eax
)
1216 (y :scs
(unsigned-reg unsigned-stack
))
1217 (carry-in :scs
(unsigned-reg unsigned-stack
)))
1218 (:arg-types unsigned-num unsigned-num unsigned-num
)
1219 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0)
1220 :to
(:result
1) :target lo
) eax
)
1221 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
1)
1222 :to
(:result
0) :target hi
) edx
)
1223 (:results
(hi :scs
(unsigned-reg))
1224 (lo :scs
(unsigned-reg)))
1225 (:result-types unsigned-num unsigned-num
)
1229 (inst add eax carry-in
)
1234 (define-vop (bignum-mult-and-add-4-arg)
1235 (:translate sb
!bignum
::%multiply-and-add
)
1236 (:policy
:fast-safe
)
1237 (:args
(x :scs
(unsigned-reg) :target eax
)
1238 (y :scs
(unsigned-reg unsigned-stack
))
1239 (prev :scs
(unsigned-reg unsigned-stack
))
1240 (carry-in :scs
(unsigned-reg unsigned-stack
)))
1241 (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num
)
1242 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0)
1243 :to
(:result
1) :target lo
) eax
)
1244 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
1)
1245 :to
(:result
0) :target hi
) edx
)
1246 (:results
(hi :scs
(unsigned-reg))
1247 (lo :scs
(unsigned-reg)))
1248 (:result-types unsigned-num unsigned-num
)
1254 (inst add eax carry-in
)
1260 (define-vop (bignum-mult)
1261 (:translate sb
!bignum
::%multiply
)
1262 (:policy
:fast-safe
)
1263 (:args
(x :scs
(unsigned-reg) :target eax
)
1264 (y :scs
(unsigned-reg unsigned-stack
)))
1265 (:arg-types unsigned-num unsigned-num
)
1266 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
0)
1267 :to
(:result
1) :target lo
) eax
)
1268 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
1)
1269 :to
(:result
0) :target hi
) edx
)
1270 (:results
(hi :scs
(unsigned-reg))
1271 (lo :scs
(unsigned-reg)))
1272 (:result-types unsigned-num unsigned-num
)
1279 (define-vop (bignum-lognot lognot-mod32
/unsigned
=>unsigned
)
1280 (:translate sb
!bignum
::%lognot
))
1282 (define-vop (fixnum-to-digit)
1283 (:translate sb
!bignum
::%fixnum-to-digit
)
1284 (:policy
:fast-safe
)
1285 (:args
(fixnum :scs
(any-reg control-stack
) :target digit
))
1286 (:arg-types tagged-num
)
1287 (:results
(digit :scs
(unsigned-reg)
1288 :load-if
(not (and (sc-is fixnum control-stack
)
1289 (sc-is digit unsigned-stack
)
1290 (location= fixnum digit
)))))
1291 (:result-types unsigned-num
)
1294 (inst sar digit
2)))
1296 (define-vop (bignum-floor)
1297 (:translate sb
!bignum
::%floor
)
1298 (:policy
:fast-safe
)
1299 (:args
(div-high :scs
(unsigned-reg) :target edx
)
1300 (div-low :scs
(unsigned-reg) :target eax
)
1301 (divisor :scs
(unsigned-reg unsigned-stack
)))
1302 (:arg-types unsigned-num unsigned-num unsigned-num
)
1303 (:temporary
(:sc unsigned-reg
:offset eax-offset
:from
(:argument
1)
1304 :to
(:result
0) :target quo
) eax
)
1305 (:temporary
(:sc unsigned-reg
:offset edx-offset
:from
(:argument
0)
1306 :to
(:result
1) :target rem
) edx
)
1307 (:results
(quo :scs
(unsigned-reg))
1308 (rem :scs
(unsigned-reg)))
1309 (:result-types unsigned-num unsigned-num
)
1313 (inst div eax divisor
)
1317 (define-vop (signify-digit)
1318 (:translate sb
!bignum
::%fixnum-digit-with-correct-sign
)
1319 (:policy
:fast-safe
)
1320 (:args
(digit :scs
(unsigned-reg unsigned-stack
) :target res
))
1321 (:arg-types unsigned-num
)
1322 (:results
(res :scs
(any-reg signed-reg
)
1323 :load-if
(not (and (sc-is digit unsigned-stack
)
1324 (sc-is res control-stack signed-stack
)
1325 (location= digit res
)))))
1326 (:result-types signed-num
)
1329 (when (sc-is res any-reg control-stack
)
1332 (define-vop (digit-ashr)
1333 (:translate sb
!bignum
::%ashr
)
1334 (:policy
:fast-safe
)
1335 (:args
(digit :scs
(unsigned-reg unsigned-stack
) :target result
)
1336 (count :scs
(unsigned-reg) :target ecx
))
1337 (:arg-types unsigned-num positive-fixnum
)
1338 (:temporary
(:sc unsigned-reg
:offset ecx-offset
:from
(:argument
1)) ecx
)
1339 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)
1340 :load-if
(not (and (sc-is result unsigned-stack
)
1341 (location= digit result
)))))
1342 (:result-types unsigned-num
)
1346 (inst sar result
:cl
)))
1348 (define-vop (digit-lshr digit-ashr
)
1349 (:translate sb
!bignum
::%digit-logical-shift-right
)
1353 (inst shr result
:cl
)))
1355 (define-vop (digit-ashl digit-ashr
)
1356 (:translate sb
!bignum
::%ashl
)
1360 (inst shl result
:cl
)))
1362 ;;;; static functions
1364 (define-static-fun two-arg-
/ (x y
) :translate
/)
1366 (define-static-fun two-arg-gcd
(x y
) :translate gcd
)
1367 (define-static-fun two-arg-lcm
(x y
) :translate lcm
)
1369 (define-static-fun two-arg-and
(x y
) :translate logand
)
1370 (define-static-fun two-arg-ior
(x y
) :translate logior
)
1371 (define-static-fun two-arg-xor
(x y
) :translate logxor
)
1374 ;;; Support for the Mersenne Twister, MT19937, random number generator
1375 ;;; due to Matsumoto and Nishimura.
1377 ;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A
1378 ;;; 623-dimensionally equidistributed uniform pseudorandom number
1379 ;;; generator.", ACM Transactions on Modeling and Computer Simulation,
1380 ;;; 1997, to appear.
1383 ;;; 0-1: Constant matrix A. [0, #x9908b0df] (not used here)
1384 ;;; 2: Index; init. to 1.
1386 (defknown random-mt19937
((simple-array (unsigned-byte 32) (*)))
1387 (unsigned-byte 32) ())
1388 (define-vop (random-mt19937)
1389 (:policy
:fast-safe
)
1390 (:translate random-mt19937
)
1391 (:args
(state :scs
(descriptor-reg) :to
:result
))
1392 (:arg-types simple-array-unsigned-byte-32
)
1393 (:temporary
(:sc unsigned-reg
:from
(:eval
0) :to
:result
) k
)
1394 (:temporary
(:sc unsigned-reg
:offset eax-offset
1395 :from
(:eval
0) :to
:result
) tmp
)
1396 (:results
(y :scs
(unsigned-reg) :from
(:eval
0)))
1397 (:result-types unsigned-num
)
1399 (inst mov k
(make-ea :dword
:base state
1400 :disp
(- (* (+ 2 vector-data-offset
)
1402 other-pointer-lowtag
)))
1404 (inst jmp
:ne no-update
)
1405 (inst mov tmp state
) ; The state is passed in EAX.
1406 (inst call
(make-fixup 'random-mt19937-update
:assembly-routine
))
1407 ;; Restore k, and set to 0.
1411 (inst mov y
(make-ea :dword
:base state
:index k
:scale
4
1412 :disp
(- (* (+ 3 vector-data-offset
)
1414 other-pointer-lowtag
)))
1417 (inst xor y
(make-ea :dword
:base state
:index k
:scale
4
1418 :disp
(- (* (+ 3 vector-data-offset
)
1420 other-pointer-lowtag
)))
1421 ;; y ^= (y << 7) & #x9d2c5680
1425 (inst mov
(make-ea :dword
:base state
1426 :disp
(- (* (+ 2 vector-data-offset
)
1428 other-pointer-lowtag
))
1430 (inst and tmp
#x9d2c5680
)
1432 ;; y ^= (y << 15) & #xefc60000
1435 (inst and tmp
#xefc60000
)
1444 (defknown %lea
((or (signed-byte 32) (unsigned-byte 32))
1445 (or (signed-byte 32) (unsigned-byte 32))
1446 (member 1 2 4 8) (signed-byte 32))
1447 (or (signed-byte 32) (unsigned-byte 32))
1448 (foldable flushable
))
1450 (defoptimizer (%lea derive-type
) ((base index scale disp
))
1451 (when (and (constant-continuation-p scale
)
1452 (constant-continuation-p disp
))
1453 (let ((scale (continuation-value scale
))
1454 (disp (continuation-value disp
))
1455 (base-type (continuation-type base
))
1456 (index-type (continuation-type index
)))
1457 (when (and (numeric-type-p base-type
)
1458 (numeric-type-p index-type
))
1459 (let ((base-lo (numeric-type-low base-type
))
1460 (base-hi (numeric-type-high base-type
))
1461 (index-lo (numeric-type-low index-type
))
1462 (index-hi (numeric-type-high index-type
)))
1463 (make-numeric-type :class
'integer
1465 :low
(when (and base-lo index-lo
)
1466 (+ base-lo
(* index-lo scale
) disp
))
1467 :high
(when (and base-hi index-hi
)
1468 (+ base-hi
(* index-hi scale
) disp
))))))))
1470 (defun %lea
(base index scale disp
)
1471 (+ base
(* index scale
) disp
))
1473 (in-package "SB!VM")
1475 (define-vop (%lea
/unsigned
=>unsigned
)
1477 (:policy
:fast-safe
)
1478 (:args
(base :scs
(unsigned-reg))
1479 (index :scs
(unsigned-reg)))
1481 (:arg-types unsigned-num unsigned-num
1482 (:constant
(member 1 2 4 8))
1483 (:constant
(signed-byte 32)))
1484 (:results
(r :scs
(unsigned-reg)))
1485 (:result-types unsigned-num
)
1487 (inst lea r
(make-ea :dword
:base base
:index index
1488 :scale scale
:disp disp
))))
1490 (define-vop (%lea
/signed
=>signed
)
1492 (:policy
:fast-safe
)
1493 (:args
(base :scs
(signed-reg))
1494 (index :scs
(signed-reg)))
1496 (:arg-types signed-num signed-num
1497 (:constant
(member 1 2 4 8))
1498 (:constant
(signed-byte 32)))
1499 (:results
(r :scs
(signed-reg)))
1500 (:result-types signed-num
)
1502 (inst lea r
(make-ea :dword
:base base
:index index
1503 :scale scale
:disp disp
))))
1505 (define-vop (%lea
/fixnum
=>fixnum
)
1507 (:policy
:fast-safe
)
1508 (:args
(base :scs
(any-reg))
1509 (index :scs
(any-reg)))
1511 (:arg-types tagged-num tagged-num
1512 (:constant
(member 1 2 4 8))
1513 (:constant
(signed-byte 32)))
1514 (:results
(r :scs
(any-reg)))
1515 (:result-types tagged-num
)
1517 (inst lea r
(make-ea :dword
:base base
:index index
1518 :scale scale
:disp disp
))))
1522 ;;; This is essentially a straight implementation of the algorithm in
1523 ;;; "Strength Reduction of Multiplications by Integer Constants",
1524 ;;; Youfeng Wu, ACM SIGPLAN Notices, Vol. 30, No.2, February 1995.
1525 (defun basic-decompose-multiplication (arg num n-bits condensed
)
1526 (case (aref condensed
0)
1528 (let ((tmp (min 3 (aref condensed
1))))
1529 (decf (aref condensed
1) tmp
)
1530 `(truly-the (unsigned-byte 32)
1532 ,(decompose-multiplication
1533 arg
(ash (1- num
) (- tmp
)) (1- n-bits
) (subseq condensed
1))
1536 (let ((r0 (aref condensed
0)))
1537 (incf (aref condensed
1) r0
)
1538 `(truly-the (unsigned-byte 32)
1539 (%lea
,(decompose-multiplication
1540 arg
(- num
(ash 1 r0
)) (1- n-bits
) (subseq condensed
1))
1543 (t (let ((r0 (aref condensed
0)))
1544 (setf (aref condensed
0) 0)
1545 `(truly-the (unsigned-byte 32)
1546 (ash ,(decompose-multiplication
1547 arg
(ash num
(- r0
)) n-bits condensed
)
1550 (defun decompose-multiplication (arg num n-bits condensed
)
1555 `(truly-the (unsigned-byte 32) (ash ,arg
,(1- (integer-length num
)))))
1556 ((let ((max 0) (end 0))
1557 (loop for i from
2 to
(length condensed
)
1558 for j
= (reduce #'+ (subseq condensed
0 i
))
1559 when
(and (> (- (* 2 i
) 3 j
) max
)
1560 (< (+ (ash 1 (1+ j
))
1561 (ash (ldb (byte (- 32 (1+ j
)) (1+ j
)) num
)
1564 do
(setq max
(- (* 2 i
) 3 j
)
1567 (let ((j (reduce #'+ (subseq condensed
0 end
))))
1568 (let ((n2 (+ (ash 1 (1+ j
))
1569 (ash (ldb (byte (- 32 (1+ j
)) (1+ j
)) num
) (1+ j
))))
1570 (n1 (1+ (ldb (byte (1+ j
) 0) (lognot num
)))))
1571 `(truly-the (unsigned-byte 32)
1572 (- ,(optimize-multiply arg n2
) ,(optimize-multiply arg n1
))))))))
1573 ((dolist (i '(9 5 3))
1574 (when (integerp (/ num i
))
1575 (when (< (logcount (/ num i
)) (logcount num
))
1577 (return `(let ((,x
,(optimize-multiply arg
(/ num i
))))
1578 (truly-the (unsigned-byte 32)
1579 (%lea
,x
,x
(1- ,i
) 0)))))))))
1580 (t (basic-decompose-multiplication arg num n-bits condensed
))))
1582 (defun optimize-multiply (arg x
)
1583 (let* ((n-bits (logcount x
))
1584 (condensed (make-array n-bits
)))
1585 (let ((count 0) (bit 0))
1587 (cond ((logbitp i x
)
1588 (setf (aref condensed bit
) count
)
1592 (decompose-multiplication arg x n-bits condensed
)))
1594 (deftransform * ((x y
)
1595 ((unsigned-byte 32) (constant-arg (unsigned-byte 32)))
1597 "recode as leas, shifts and adds"
1598 (let ((y (continuation-value y
)))
1600 ((= y
(ash 1 (integer-length y
)))
1601 ;; there's a generic transform for y = 2^k
1602 (give-up-ir1-transform))
1603 ((member y
'(3 5 9))
1604 ;; we can do these multiplications directly using LEA
1605 `(%lea x x
,(1- y
) 0))
1606 ((member :pentium4
*backend-subfeatures
*)
1607 ;; the pentium4's multiply unit is reportedly very good
1608 (give-up-ir1-transform))
1609 ;; FIXME: should make this more fine-grained. If nothing else,
1610 ;; there should probably be a cutoff of about 9 instructions on
1611 ;; pentium-class machines.
1612 (t (optimize-multiply 'x y
)))))
1614 ;;; FIXME: we should also be able to write an optimizer or two to
1615 ;;; convert (+ (* x 2) 17), (- (* x 9) 5) to a %LEA.