dc00bd523b98b069d90cf25f6409093479e2934f
[sbcl.git] / src / compiler / x86 / arith.lisp
1 ;;;; the VM definition arithmetic VOPs for the x86
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!VM")
13 \f
14 ;;;; unary operations
15
16 (define-vop (fast-safe-arith-op)
17   (:policy :fast-safe)
18   (:effects)
19   (:affected))
20
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))
27
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))
34
35 (define-vop (fast-negate/fixnum fixnum-unop)
36   (:translate %negate)
37   (:generator 1
38     (move res x)
39     (inst neg res)))
40
41 (define-vop (fast-negate/signed signed-unop)
42   (:translate %negate)
43   (:generator 2
44     (move res x)
45     (inst neg res)))
46
47 (define-vop (fast-lognot/fixnum fixnum-unop)
48   (:translate lognot)
49   (:generator 2
50     (move res x)
51     (inst xor res (fixnumize -1))))
52
53 (define-vop (fast-lognot/signed signed-unop)
54   (:translate lognot)
55   (:generator 1
56     (move res x)
57     (inst not res)))
58 \f
59 ;;;; binary fixnum operations
60
61 ;;; Assume that any constant operand is the second arg...
62
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)
66                                (sc-is y any-reg)
67                                (sc-is r control-stack)
68                                (location= x r))))
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)
73                                   (sc-is y any-reg)
74                                   (sc-is r control-stack)
75                                   (location= x r)))))
76   (:result-types tagged-num)
77   (:note "inline fixnum arithmetic"))
78
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)
84                                (location= x r))))
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)
91                                (location= x r)))))
92   (:result-types unsigned-num)
93   (:note "inline (unsigned-byte 32) arithmetic"))
94
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)
98                                (sc-is y signed-reg)
99                                (sc-is r signed-stack)
100                                (location= x r))))
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)
105                                (sc-is y signed-reg)
106                                (sc-is r signed-stack)
107                                (location= x r)))))
108   (:result-types signed-num)
109   (:note "inline (signed-byte 32) arithmetic"))
110
111 (define-vop (fast-fixnum-binop-c fast-safe-arith-op)
112   (:args (x :target r :scs (any-reg control-stack)))
113   (:info y)
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"))
119
120 (define-vop (fast-unsigned-binop-c fast-safe-arith-op)
121   (:args (x :target r :scs (unsigned-reg unsigned-stack)))
122   (:info y)
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"))
128
129 (define-vop (fast-signed-binop-c fast-safe-arith-op)
130   (:args (x :target r :scs (signed-reg signed-stack)))
131   (:info y)
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"))
137
138 (macrolet ((define-binop (translate untagged-penalty op)
139              `(progn
140                 (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
141                              fast-fixnum-binop)
142                   (:translate ,translate)
143                   (:generator 2
144                               (move r x)
145                               (inst ,op r y)))
146                 (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
147                              fast-fixnum-binop-c)
148                   (:translate ,translate)
149                   (:generator 1
150                   (move r x)
151                   (inst ,op r (fixnumize y))))
152                 (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
153                              fast-signed-binop)
154                   (:translate ,translate)
155                   (:generator ,(1+ untagged-penalty)
156                   (move r x)
157                   (inst ,op r y)))
158                 (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
159                              fast-signed-binop-c)
160                   (:translate ,translate)
161                   (:generator ,untagged-penalty
162                   (move r x)
163                   (inst ,op r y)))
164                 (define-vop (,(symbolicate "FAST-"
165                                            translate
166                                            "/UNSIGNED=>UNSIGNED")
167                 fast-unsigned-binop)
168                   (:translate ,translate)
169                   (:generator ,(1+ untagged-penalty)
170                   (move r x)
171                   (inst ,op r y)))
172                 (define-vop (,(symbolicate 'fast-
173                                            translate
174                                            '-c/unsigned=>unsigned)
175                              fast-unsigned-binop-c)
176                   (:translate ,translate)
177                   (:generator ,untagged-penalty
178                   (move r x)
179                   (inst ,op r y))))))
180
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))
186
187
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)
191   (:translate +)
192   (:args (x :scs (any-reg) :target r
193             :load-if (not (and (sc-is x control-stack)
194                                (sc-is y any-reg)
195                                (sc-is r control-stack)
196                                (location= x r))))
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)
201                                   (sc-is y any-reg)
202                                   (sc-is r control-stack)
203                                   (location= x r)))))
204   (:result-types tagged-num)
205   (:note "inline fixnum arithmetic")
206   (:generator 2
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)))
210           (t
211            (move r x)
212            (inst add r y)))))
213
214 (define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op)
215   (:translate +)
216   (:args (x :target r :scs (any-reg control-stack)))
217   (:info y)
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")
223   (:generator 1
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))))
226           (t
227            (move r x)
228            (inst add r (fixnumize y))))))
229
230 (define-vop (fast-+/signed=>signed fast-safe-arith-op)
231   (:translate +)
232   (:args (x :scs (signed-reg) :target r
233             :load-if (not (and (sc-is x signed-stack)
234                                (sc-is y signed-reg)
235                                (sc-is r signed-stack)
236                                (location= x r))))
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)
241                                   (sc-is y signed-reg)
242                                   (location= x r)))))
243   (:result-types signed-num)
244   (:note "inline (signed-byte 32) arithmetic")
245   (:generator 5
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)))
249           (t
250            (move r x)
251            (inst add r y)))))
252
253
254 ;;;; Special logand cases: (logand signed unsigned) => unsigned
255
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)
262                                (location= x r))))
263          (y :scs (unsigned-reg unsigned-stack)))
264   (:arg-types signed-num unsigned-num))
265
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))))
270
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)
275                                (sc-is y signed-reg)
276                                (sc-is r unsigned-stack)
277                                (location= x r))))
278          (y :scs (signed-reg signed-stack)))
279   (:arg-types unsigned-num signed-num))
280 \f
281
282 (define-vop (fast-+-c/signed=>signed fast-safe-arith-op)
283   (:translate +)
284   (:args (x :target r :scs (signed-reg signed-stack)))
285   (:info y)
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")
291   (:generator 4
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)))
295           (t
296            (move r x)
297            (if (= y 1)
298                (inst inc r)
299              (inst add r y))))))
300
301 (define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op)
302   (:translate +)
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)
307                                (location= x r))))
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)
314                                   (location= x r)))))
315   (:result-types unsigned-num)
316   (:note "inline (unsigned-byte 32) arithmetic")
317   (:generator 5
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)))
321           (t
322            (move r x)
323            (inst add r y)))))
324
325 (define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op)
326   (:translate +)
327   (:args (x :target r :scs (unsigned-reg unsigned-stack)))
328   (:info y)
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")
334   (:generator 4
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)))
338           (t
339            (move r x)
340            (if (= y 1)
341                (inst inc r)
342              (inst add r y))))))
343 \f
344 ;;;; multiplication and division
345
346 (define-vop (fast-*/fixnum=>fixnum fast-safe-arith-op)
347   (:translate *)
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")
355   (:generator 4
356     (move r x)
357     (inst sar r 2)
358     (inst imul r y)))
359
360 (define-vop (fast-*-c/fixnum=>fixnum fast-safe-arith-op)
361   (:translate *)
362   ;; We need different loading characteristics.
363   (:args (x :scs (any-reg control-stack)))
364   (:info y)
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")
369   (:generator 3
370     (inst imul r x y)))
371
372 (define-vop (fast-*/signed=>signed fast-safe-arith-op)
373   (:translate *)
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")
381   (:generator 5
382     (move r x)
383     (inst imul r y)))
384
385 (define-vop (fast-*-c/signed=>signed fast-safe-arith-op)
386   (:translate *)
387   ;; We need different loading characteristics.
388   (:args (x :scs (signed-reg signed-stack)))
389   (:info y)
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")
394   (:generator 4
395     (inst imul r x y)))
396
397 (define-vop (fast-*/unsigned=>unsigned fast-safe-arith-op)
398   (:translate *)
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)
406   (:ignore edx)
407   (:results (result :scs (unsigned-reg)))
408   (:result-types unsigned-num)
409   (:note "inline (unsigned-byte 32) arithmetic")
410   (:vop-var vop)
411   (:save-p :compute-only)
412   (:generator 6
413     (move eax x)
414     (inst mul eax y)
415     (move result eax)))
416
417
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")
431   (:vop-var vop)
432   (:save-p :compute-only)
433   (:generator 31
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
437           (inst cmp y 0))
438       (inst jmp :eq zero))
439     (move eax x)
440     (inst cdq)
441     (inst idiv eax y)
442     (if (location= quo eax)
443         (inst shl eax 2)
444         (inst lea quo (make-ea :dword :index eax :scale 4)))
445     (move rem edx)))
446
447 (define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
448   (:translate truncate)
449   (:args (x :scs (any-reg) :target eax))
450   (:info y)
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")
461   (:vop-var vop)
462   (:save-p :compute-only)
463   (:generator 30
464     (move eax x)
465     (inst cdq)
466     (inst mov y-arg (fixnumize y))
467     (inst idiv eax y-arg)
468     (if (location= quo eax)
469         (inst shl eax 2)
470         (inst lea quo (make-ea :dword :index eax :scale 4)))
471     (move rem edx)))
472
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")
486   (:vop-var vop)
487   (:save-p :compute-only)
488   (:generator 33
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
492           (inst cmp y 0))
493       (inst jmp :eq zero))
494     (move eax x)
495     (inst xor edx edx)
496     (inst div eax y)
497     (move quo eax)
498     (move rem edx)))
499
500 (define-vop (fast-truncate-c/unsigned=>unsigned fast-safe-arith-op)
501   (:translate truncate)
502   (:args (x :scs (unsigned-reg) :target eax))
503   (:info y)
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")
514   (:vop-var vop)
515   (:save-p :compute-only)
516   (:generator 32
517     (move eax x)
518     (inst xor edx edx)
519     (inst mov y-arg y)
520     (inst div eax y-arg)
521     (move quo eax)
522     (move rem edx)))
523
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")
537   (:vop-var vop)
538   (:save-p :compute-only)
539   (:generator 33
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
543           (inst cmp y 0))
544       (inst jmp :eq zero))
545     (move eax x)
546     (inst cdq)
547     (inst idiv eax y)
548     (move quo eax)
549     (move rem edx)))
550
551 (define-vop (fast-truncate-c/signed=>signed fast-safe-arith-op)
552   (:translate truncate)
553   (:args (x :scs (signed-reg) :target eax))
554   (:info y)
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")
565   (:vop-var vop)
566   (:save-p :compute-only)
567   (:generator 32
568     (move eax x)
569     (inst cdq)
570     (inst mov y-arg y)
571     (inst idiv eax y-arg)
572     (move quo eax)
573     (move rem edx)))
574
575
576 \f
577 ;;;; Shifting
578 (define-vop (fast-ash-c/fixnum=>fixnum)
579   (:translate ash)
580   (:policy :fast-safe)
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)))))
585   (:info amount)
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)
592   (:note "inline ASH")
593   (:generator 2
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)))
600           (t
601            (move result number)
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))
606                  (t
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)))))))
613
614 (define-vop (fast-ash-left/fixnum=>fixnum)
615   (:translate ash)
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)
628   (:policy :fast-safe)
629   (:note "inline ASH")
630   (:generator 3
631     (move result number)
632     (move ecx amount)
633     ;; The result-type ensures us that this shift will not overflow.
634     (inst shl result :cl)))
635
636 (define-vop (fast-ash-c)
637   (:translate ash)
638   (:policy :fast-safe)
639   (:args (number :scs (signed-reg unsigned-reg) :target result
640                  :load-if (not (and (sc-is number signed-stack unsigned-stack)
641                                     (sc-is result signed-stack unsigned-stack)
642                                     (location= number result)))))
643   (:info amount)
644   (:arg-types (:or signed-num unsigned-num) (:constant integer))
645   (:results (result :scs (signed-reg unsigned-reg)
646                     :load-if (not
647                               (and (sc-is number signed-stack unsigned-stack)
648                                    (sc-is result signed-stack unsigned-stack)
649                                    (location= number result)))))
650   (:result-types (:or signed-num unsigned-num))
651   (:note "inline ASH")
652   (:generator 3
653     (cond ((and (= amount 1) (not (location= number result)))
654            (inst lea result (make-ea :dword :index number :scale 2)))
655           ((and (= amount 2) (not (location= number result)))
656            (inst lea result (make-ea :dword :index number :scale 4)))
657           ((and (= amount 3) (not (location= number result)))
658            (inst lea result (make-ea :dword :index number :scale 8)))
659           (t
660            (move result number)
661            (cond ((plusp amount)
662                   ;; We don't have to worry about overflow because of the
663                   ;; result type restriction.
664                   (inst shl result amount))
665                  ((sc-is number signed-reg signed-stack)
666                   ;; If the amount is greater than 31, only shift by 31. We
667                   ;; have to do this because the shift instructions only look
668                   ;; at the low five bits of the result.
669                   (inst sar result (min 31 (- amount))))
670                  (t
671                   (inst shr result (min 31 (- amount)))))))))
672
673 (define-vop (fast-ash-left)
674   (:translate ash)
675   (:args (number :scs (signed-reg unsigned-reg) :target result
676                  :load-if (not (and (sc-is number signed-stack unsigned-stack)
677                                     (sc-is result signed-stack unsigned-stack)
678                                     (location= number result))))
679          (amount :scs (unsigned-reg) :target ecx))
680   (:arg-types (:or signed-num unsigned-num) positive-fixnum)
681   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
682   (:results (result :scs (signed-reg unsigned-reg) :from (:argument 0)
683                     :load-if (not
684                               (and (sc-is number signed-stack unsigned-stack)
685                                    (sc-is result signed-stack unsigned-stack)
686                                    (location= number result)))))
687   (:result-types (:or signed-num unsigned-num))
688   (:policy :fast-safe)
689   (:note "inline ASH")
690   (:generator 4
691     (move result number)
692     (move ecx amount)
693     ;; The result-type ensures us that this shift will not overflow.
694     (inst shl result :cl)))
695
696 (define-vop (fast-ash)
697   (:translate ash)
698   (:policy :fast-safe)
699   (:args (number :scs (signed-reg unsigned-reg) :target result)
700          (amount :scs (signed-reg) :target ecx))
701   (:arg-types (:or signed-num unsigned-num) signed-num)
702   (:results (result :scs (signed-reg unsigned-reg) :from (:argument 0)))
703   (:result-types (:or signed-num unsigned-num))
704   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
705   (:note "inline ASH")
706   (:generator 5
707     (move result number)
708      (move ecx amount)
709     (inst or ecx ecx)
710     (inst jmp :ns positive)
711     (inst neg ecx)
712     (inst cmp ecx 31)
713     (inst jmp :be okay)
714     (inst mov ecx 31)
715     OKAY
716     (sc-case number
717       (signed-reg (inst sar result :cl))
718       (unsigned-reg (inst shr result :cl)))
719     (inst jmp done)
720
721     POSITIVE
722     ;; The result-type ensures us that this shift will not overflow.
723     (inst shl result :cl)
724
725     DONE))
726 \f
727 ;;; Note: documentation for this function is wrong - rtfm
728 (define-vop (signed-byte-32-len)
729   (:translate integer-length)
730   (:note "inline (signed-byte 32) integer-length")
731   (:policy :fast-safe)
732   (:args (arg :scs (signed-reg) :target res))
733   (:arg-types signed-num)
734   (:results (res :scs (unsigned-reg)))
735   (:result-types unsigned-num)
736   (:generator 28
737     (move res arg)
738     (inst cmp res 0)
739     (inst jmp :ge POS)
740     (inst not res)
741     POS
742     (inst bsr res res)
743     (inst jmp :z zero)
744     (inst inc res)
745     (inst jmp done)
746     ZERO
747     (inst xor res res)
748     DONE))
749
750 (define-vop (unsigned-byte-32-len)
751   (:translate integer-length)
752   (:note "inline (unsigned-byte 32) integer-length")
753   (:policy :fast-safe)
754   (:args (arg :scs (unsigned-reg)))
755   (:arg-types unsigned-num)
756   (:results (res :scs (unsigned-reg)))
757   (:result-types unsigned-num)
758   (:generator 26
759     (inst bsr res arg)
760     (inst jmp :z zero)
761     (inst inc res)
762     (inst jmp done)
763     ZERO
764     (inst xor res res)
765     DONE))
766
767 (define-vop (unsigned-byte-32-count)
768   (:translate logcount)
769   (:note "inline (unsigned-byte 32) logcount")
770   (:policy :fast-safe)
771   (:args (arg :scs (unsigned-reg)))
772   (:arg-types unsigned-num)
773   (:results (result :scs (unsigned-reg)))
774   (:result-types positive-fixnum)
775   (:temporary (:sc unsigned-reg :from (:argument 0)) temp)
776   (:generator 30
777     (move result arg)
778
779     (inst mov temp result)
780     (inst shr temp 1)
781     (inst and result #x55555555)
782     (inst and temp #x55555555)
783     (inst add result temp)
784
785     (inst mov temp result)
786     (inst shr temp 2)
787     (inst and result #x33333333)
788     (inst and temp #x33333333)
789     (inst add result temp)
790
791     (inst mov temp result)
792     (inst shr temp 4)
793     (inst and result #x0f0f0f0f)
794     (inst and temp #x0f0f0f0f)
795     (inst add result temp)
796
797     (inst mov temp result)
798     (inst shr temp 8)
799     (inst and result #x00ff00ff)
800     (inst and temp #x00ff00ff)
801     (inst add result temp)
802
803     (inst mov temp result)
804     (inst shr temp 16)
805     (inst and result #x0000ffff)
806     (inst and temp #x0000ffff)
807     (inst add result temp)))
808 \f
809 ;;;; binary conditional VOPs
810
811 (define-vop (fast-conditional)
812   (:conditional)
813   (:info target not-p)
814   (:effects)
815   (:affected)
816   (:policy :fast-safe))
817
818 (define-vop (fast-conditional/fixnum fast-conditional)
819   (:args (x :scs (any-reg)
820             :load-if (not (and (sc-is x control-stack)
821                                (sc-is y any-reg))))
822          (y :scs (any-reg control-stack)))
823   (:arg-types tagged-num tagged-num)
824   (:note "inline fixnum comparison"))
825
826 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
827   (:args (x :scs (any-reg control-stack)))
828   (:arg-types tagged-num (:constant (signed-byte 30)))
829   (:info target not-p y))
830
831 (define-vop (fast-conditional/signed fast-conditional)
832   (:args (x :scs (signed-reg)
833             :load-if (not (and (sc-is x signed-stack)
834                                (sc-is y signed-reg))))
835          (y :scs (signed-reg signed-stack)))
836   (:arg-types signed-num signed-num)
837   (:note "inline (signed-byte 32) comparison"))
838
839 (define-vop (fast-conditional-c/signed fast-conditional/signed)
840   (:args (x :scs (signed-reg signed-stack)))
841   (:arg-types signed-num (:constant (signed-byte 32)))
842   (:info target not-p y))
843
844 (define-vop (fast-conditional/unsigned fast-conditional)
845   (:args (x :scs (unsigned-reg)
846             :load-if (not (and (sc-is x unsigned-stack)
847                                (sc-is y unsigned-reg))))
848          (y :scs (unsigned-reg unsigned-stack)))
849   (:arg-types unsigned-num unsigned-num)
850   (:note "inline (unsigned-byte 32) comparison"))
851
852 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
853   (:args (x :scs (unsigned-reg unsigned-stack)))
854   (:arg-types unsigned-num (:constant (unsigned-byte 32)))
855   (:info target not-p y))
856
857
858 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
859              `(progn
860                 ,@(mapcar
861                    (lambda (suffix cost signed)
862                      `(define-vop (;; FIXME: These could be done more
863                                    ;; cleanly with SYMBOLICATE.
864                                    ,(intern (format nil "~:@(FAST-IF-~A~A~)"
865                                                     tran suffix))
866                                    ,(intern
867                                      (format nil "~:@(FAST-CONDITIONAL~A~)"
868                                              suffix)))
869                         (:translate ,tran)
870                         (:generator ,cost
871                                     (inst cmp x
872                                           ,(if (eq suffix '-c/fixnum)
873                                                '(fixnumize y)
874                                                'y))
875                                     (inst jmp (if not-p
876                                                   ,(if signed
877                                                        not-cond
878                                                        not-unsigned)
879                                                   ,(if signed
880                                                        cond
881                                                        unsigned))
882                                           target))))
883                    '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
884                    '(4 3 6 5 6 5)
885                    '(t t t t nil nil)))))
886
887   (define-conditional-vop < :l :b :ge :ae)
888   (define-conditional-vop > :g :a :le :be))
889
890 (define-vop (fast-if-eql/signed fast-conditional/signed)
891   (:translate eql)
892   (:generator 6
893     (inst cmp x y)
894     (inst jmp (if not-p :ne :e) target)))
895
896 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
897   (:translate eql)
898   (:generator 5
899     (cond ((and (sc-is x signed-reg) (zerop y))
900            (inst test x x))  ; smaller instruction
901           (t
902            (inst cmp x y)))
903     (inst jmp (if not-p :ne :e) target)))
904
905 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
906   (:translate eql)
907   (:generator 6
908     (inst cmp x y)
909     (inst jmp (if not-p :ne :e) target)))
910
911 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
912   (:translate eql)
913   (:generator 5
914     (cond ((and (sc-is x unsigned-reg) (zerop y))
915            (inst test x x))  ; smaller instruction
916           (t
917            (inst cmp x y)))
918     (inst jmp (if not-p :ne :e) target)))
919
920 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
921 ;;; known fixnum.
922
923 ;;; These versions specify a fixnum restriction on their first arg. We have
924 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
925 ;;; the first arg and a higher cost. The reason for doing this is to prevent
926 ;;; fixnum specific operations from being used on word integers, spuriously
927 ;;; consing the argument.
928
929 (define-vop (fast-eql/fixnum fast-conditional)
930   (:args (x :scs (any-reg)
931             :load-if (not (and (sc-is x control-stack)
932                                (sc-is y any-reg))))
933          (y :scs (any-reg control-stack)))
934   (:arg-types tagged-num tagged-num)
935   (:note "inline fixnum comparison")
936   (:translate eql)
937   (:generator 4
938     (inst cmp x y)
939     (inst jmp (if not-p :ne :e) target)))
940 (define-vop (generic-eql/fixnum fast-eql/fixnum)
941   (:args (x :scs (any-reg descriptor-reg)
942             :load-if (not (and (sc-is x control-stack)
943                                (sc-is y any-reg))))
944          (y :scs (any-reg control-stack)))
945   (:arg-types * tagged-num)
946   (:variant-cost 7))
947
948 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
949   (:args (x :scs (any-reg control-stack)))
950   (:arg-types tagged-num (:constant (signed-byte 30)))
951   (:info target not-p y)
952   (:translate eql)
953   (:generator 2
954     (cond ((and (sc-is x any-reg) (zerop y))
955            (inst test x x))  ; smaller instruction
956           (t
957            (inst cmp x (fixnumize y))))
958     (inst jmp (if not-p :ne :e) target)))
959 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
960   (:args (x :scs (any-reg descriptor-reg control-stack)))
961   (:arg-types * (:constant (signed-byte 30)))
962   (:variant-cost 6))
963 \f
964 ;;;; 32-bit logical operations
965
966 (define-vop (merge-bits)
967   (:translate merge-bits)
968   (:args (shift :scs (signed-reg unsigned-reg) :target ecx)
969          (prev :scs (unsigned-reg) :target result)
970          (next :scs (unsigned-reg)))
971   (:arg-types tagged-num unsigned-num unsigned-num)
972   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 0)) ecx)
973   (:results (result :scs (unsigned-reg) :from (:argument 1)))
974   (:result-types unsigned-num)
975   (:policy :fast-safe)
976   (:generator 4
977     (move ecx shift)
978     (move result prev)
979     (inst shrd result next :cl)))
980
981 (define-source-transform 32bit-logical-not (x)
982   `(logand (lognot (the (unsigned-byte 32) ,x)) #.(1- (ash 1 32))))
983
984 (deftransform 32bit-logical-and ((x y))
985   '(logand x y))
986
987 (define-source-transform 32bit-logical-nand (x y)
988   `(32bit-logical-not (32bit-logical-and ,x ,y)))
989
990 (deftransform 32bit-logical-or ((x y))
991   '(logior x y))
992
993 (define-source-transform 32bit-logical-nor (x y)
994   `(32bit-logical-not (32bit-logical-or ,x ,y)))
995
996 (deftransform 32bit-logical-xor ((x y))
997   '(logxor x y))
998
999 (define-source-transform 32bit-logical-eqv (x y)
1000   `(32bit-logical-not (32bit-logical-xor ,x ,y)))
1001
1002 (define-source-transform 32bit-logical-orc1 (x y)
1003   `(32bit-logical-or (32bit-logical-not ,x) ,y))
1004
1005 (define-source-transform 32bit-logical-orc2 (x y)
1006   `(32bit-logical-or ,x (32bit-logical-not ,y)))
1007
1008 (define-source-transform 32bit-logical-andc1 (x y)
1009   `(32bit-logical-and (32bit-logical-not ,x) ,y))
1010
1011 (define-source-transform 32bit-logical-andc2 (x y)
1012   `(32bit-logical-and ,x (32bit-logical-not ,y)))
1013
1014 ;;; Only the lower 5 bits of the shift amount are significant.
1015 (define-vop (shift-towards-someplace)
1016   (:policy :fast-safe)
1017   (:args (num :scs (unsigned-reg) :target r)
1018          (amount :scs (signed-reg) :target ecx))
1019   (:arg-types unsigned-num tagged-num)
1020   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
1021   (:results (r :scs (unsigned-reg) :from (:argument 0)))
1022   (:result-types unsigned-num))
1023
1024 (define-vop (shift-towards-start shift-towards-someplace)
1025   (:translate shift-towards-start)
1026   (:note "SHIFT-TOWARDS-START")
1027   (:generator 1
1028     (move r num)
1029     (move ecx amount)
1030     (inst shr r :cl)))
1031
1032 (define-vop (shift-towards-end shift-towards-someplace)
1033   (:translate shift-towards-end)
1034   (:note "SHIFT-TOWARDS-END")
1035   (:generator 1
1036     (move r num)
1037     (move ecx amount)
1038     (inst shl r :cl)))
1039 \f
1040 ;;;; bignum stuff
1041
1042 (define-vop (bignum-length get-header-data)
1043   (:translate sb!bignum::%bignum-length)
1044   (:policy :fast-safe))
1045
1046 (define-vop (bignum-set-length set-header-data)
1047   (:translate sb!bignum::%bignum-set-length)
1048   (:policy :fast-safe))
1049
1050 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
1051   (unsigned-reg) unsigned-num sb!bignum::%bignum-ref)
1052
1053 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
1054   (unsigned-reg) unsigned-num sb!bignum::%bignum-set)
1055
1056 (define-vop (digit-0-or-plus)
1057   (:translate sb!bignum::%digit-0-or-plusp)
1058   (:policy :fast-safe)
1059   (:args (digit :scs (unsigned-reg)))
1060   (:arg-types unsigned-num)
1061   (:conditional)
1062   (:info target not-p)
1063   (:generator 3
1064     (inst or digit digit)
1065     (inst jmp (if not-p :s :ns) target)))
1066
1067
1068 ;;; For add and sub with carry the sc of carry argument is any-reg so
1069 ;;; the it may be passed as a fixnum or word and thus may be 0, 1, or
1070 ;;; 4. This is easy to deal with and may save a fixnum-word
1071 ;;; conversion.
1072 (define-vop (add-w/carry)
1073   (:translate sb!bignum::%add-with-carry)
1074   (:policy :fast-safe)
1075   (:args (a :scs (unsigned-reg) :target result)
1076          (b :scs (unsigned-reg unsigned-stack) :to :eval)
1077          (c :scs (any-reg) :target temp))
1078   (:arg-types unsigned-num unsigned-num positive-fixnum)
1079   (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
1080   (:results (result :scs (unsigned-reg) :from (:argument 0))
1081             (carry :scs (unsigned-reg)))
1082   (:result-types unsigned-num positive-fixnum)
1083   (:generator 4
1084     (move result a)
1085     (move temp c)
1086     (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
1087     (inst adc result b)
1088     (inst mov carry 0)
1089     (inst adc carry carry)))
1090
1091 ;;; Note: the borrow is the oppostite of the x86 convention - 1 for no
1092 ;;; borrow and 0 for a borrow.
1093 (define-vop (sub-w/borrow)
1094   (:translate sb!bignum::%subtract-with-borrow)
1095   (:policy :fast-safe)
1096   (:args (a :scs (unsigned-reg) :to :eval :target result)
1097          (b :scs (unsigned-reg unsigned-stack) :to :result)
1098          (c :scs (any-reg control-stack)))
1099   (:arg-types unsigned-num unsigned-num positive-fixnum)
1100   (:results (result :scs (unsigned-reg) :from :eval)
1101             (borrow :scs (unsigned-reg)))
1102   (:result-types unsigned-num positive-fixnum)
1103   (:generator 5
1104     (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
1105     (move result a)
1106     (inst sbb result b)
1107     (inst mov borrow 0)
1108     (inst adc borrow borrow)
1109     (inst xor borrow 1)))
1110
1111
1112 (define-vop (bignum-mult-and-add-3-arg)
1113   (:translate sb!bignum::%multiply-and-add)
1114   (:policy :fast-safe)
1115   (:args (x :scs (unsigned-reg) :target eax)
1116          (y :scs (unsigned-reg unsigned-stack))
1117          (carry-in :scs (unsigned-reg unsigned-stack)))
1118   (:arg-types unsigned-num unsigned-num unsigned-num)
1119   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1120                    :to (:result 1) :target lo) eax)
1121   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1122                    :to (:result 0) :target hi) edx)
1123   (:results (hi :scs (unsigned-reg))
1124             (lo :scs (unsigned-reg)))
1125   (:result-types unsigned-num unsigned-num)
1126   (:generator 20
1127     (move eax x)
1128     (inst mul eax y)
1129     (inst add eax carry-in)
1130     (inst adc edx 0)
1131     (move hi edx)
1132     (move lo eax)))
1133
1134 (define-vop (bignum-mult-and-add-4-arg)
1135   (:translate sb!bignum::%multiply-and-add)
1136   (:policy :fast-safe)
1137   (:args (x :scs (unsigned-reg) :target eax)
1138          (y :scs (unsigned-reg unsigned-stack))
1139          (prev :scs (unsigned-reg unsigned-stack))
1140          (carry-in :scs (unsigned-reg unsigned-stack)))
1141   (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1142   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1143                    :to (:result 1) :target lo) eax)
1144   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1145                    :to (:result 0) :target hi) edx)
1146   (:results (hi :scs (unsigned-reg))
1147             (lo :scs (unsigned-reg)))
1148   (:result-types unsigned-num unsigned-num)
1149   (:generator 20
1150     (move eax x)
1151     (inst mul eax y)
1152     (inst add eax prev)
1153     (inst adc edx 0)
1154     (inst add eax carry-in)
1155     (inst adc edx 0)
1156     (move hi edx)
1157     (move lo eax)))
1158
1159
1160 (define-vop (bignum-mult)
1161   (:translate sb!bignum::%multiply)
1162   (:policy :fast-safe)
1163   (:args (x :scs (unsigned-reg) :target eax)
1164          (y :scs (unsigned-reg unsigned-stack)))
1165   (:arg-types unsigned-num unsigned-num)
1166   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1167                    :to (:result 1) :target lo) eax)
1168   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1169                    :to (:result 0) :target hi) edx)
1170   (:results (hi :scs (unsigned-reg))
1171             (lo :scs (unsigned-reg)))
1172   (:result-types unsigned-num unsigned-num)
1173   (:generator 20
1174     (move eax x)
1175     (inst mul eax y)
1176     (move hi edx)
1177     (move lo eax)))
1178
1179 (define-vop (bignum-lognot)
1180   (:translate sb!bignum::%lognot)
1181   (:policy :fast-safe)
1182   (:args (x :scs (unsigned-reg unsigned-stack) :target r))
1183   (:arg-types unsigned-num)
1184   (:results (r :scs (unsigned-reg)
1185                :load-if (not (location= x r))))
1186   (:result-types unsigned-num)
1187   (:generator 1
1188     (move r x)
1189     (inst not r)))
1190
1191 (define-vop (fixnum-to-digit)
1192   (:translate sb!bignum::%fixnum-to-digit)
1193   (:policy :fast-safe)
1194   (:args (fixnum :scs (any-reg control-stack) :target digit))
1195   (:arg-types tagged-num)
1196   (:results (digit :scs (unsigned-reg)
1197                    :load-if (not (and (sc-is fixnum control-stack)
1198                                       (sc-is digit unsigned-stack)
1199                                       (location= fixnum digit)))))
1200   (:result-types unsigned-num)
1201   (:generator 1
1202     (move digit fixnum)
1203     (inst sar digit 2)))
1204
1205 (define-vop (bignum-floor)
1206   (:translate sb!bignum::%floor)
1207   (:policy :fast-safe)
1208   (:args (div-high :scs (unsigned-reg) :target edx)
1209          (div-low :scs (unsigned-reg) :target eax)
1210          (divisor :scs (unsigned-reg unsigned-stack)))
1211   (:arg-types unsigned-num unsigned-num unsigned-num)
1212   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
1213                    :to (:result 0) :target quo) eax)
1214   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
1215                    :to (:result 1) :target rem) edx)
1216   (:results (quo :scs (unsigned-reg))
1217             (rem :scs (unsigned-reg)))
1218   (:result-types unsigned-num unsigned-num)
1219   (:generator 300
1220     (move edx div-high)
1221     (move eax div-low)
1222     (inst div eax divisor)
1223     (move quo eax)
1224     (move rem edx)))
1225
1226 (define-vop (signify-digit)
1227   (:translate sb!bignum::%fixnum-digit-with-correct-sign)
1228   (:policy :fast-safe)
1229   (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
1230   (:arg-types unsigned-num)
1231   (:results (res :scs (any-reg signed-reg)
1232                  :load-if (not (and (sc-is digit unsigned-stack)
1233                                     (sc-is res control-stack signed-stack)
1234                                     (location= digit res)))))
1235   (:result-types signed-num)
1236   (:generator 1
1237     (move res digit)
1238     (when (sc-is res any-reg control-stack)
1239       (inst shl res 2))))
1240
1241 (define-vop (digit-ashr)
1242   (:translate sb!bignum::%ashr)
1243   (:policy :fast-safe)
1244   (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
1245          (count :scs (unsigned-reg) :target ecx))
1246   (:arg-types unsigned-num positive-fixnum)
1247   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
1248   (:results (result :scs (unsigned-reg) :from (:argument 0)
1249                     :load-if (not (and (sc-is result unsigned-stack)
1250                                        (location= digit result)))))
1251   (:result-types unsigned-num)
1252   (:generator 1
1253     (move result digit)
1254     (move ecx count)
1255     (inst sar result :cl)))
1256
1257 (define-vop (digit-lshr digit-ashr)
1258   (:translate sb!bignum::%digit-logical-shift-right)
1259   (:generator 1
1260     (move result digit)
1261     (move ecx count)
1262     (inst shr result :cl)))
1263
1264 (define-vop (digit-ashl digit-ashr)
1265   (:translate sb!bignum::%ashl)
1266   (:generator 1
1267     (move result digit)
1268     (move ecx count)
1269     (inst shl result :cl)))
1270 \f
1271 ;;;; static functions
1272
1273 (define-static-fun two-arg-/ (x y) :translate /)
1274
1275 (define-static-fun two-arg-gcd (x y) :translate gcd)
1276 (define-static-fun two-arg-lcm (x y) :translate lcm)
1277
1278 (define-static-fun two-arg-and (x y) :translate logand)
1279 (define-static-fun two-arg-ior (x y) :translate logior)
1280 (define-static-fun two-arg-xor (x y) :translate logxor)
1281
1282 \f
1283 ;;; Support for the Mersenne Twister, MT19937, random number generator
1284 ;;; due to Matsumoto and Nishimura.
1285 ;;;
1286 ;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A
1287 ;;; 623-dimensionally equidistributed uniform pseudorandom number
1288 ;;; generator.", ACM Transactions on Modeling and Computer Simulation,
1289 ;;; 1997, to appear.
1290 ;;;
1291 ;;; State:
1292 ;;;  0-1:   Constant matrix A. [0, #x9908b0df] (not used here)
1293 ;;;  2:     Index; init. to 1.
1294 ;;;  3-626: State.
1295 (defknown random-mt19937 ((simple-array (unsigned-byte 32) (*)))
1296   (unsigned-byte 32) ())
1297 (define-vop (random-mt19937)
1298   (:policy :fast-safe)
1299   (:translate random-mt19937)
1300   (:args (state :scs (descriptor-reg) :to :result))
1301   (:arg-types simple-array-unsigned-byte-32)
1302   (:temporary (:sc unsigned-reg :from (:eval 0) :to :result) k)
1303   (:temporary (:sc unsigned-reg :offset eax-offset
1304                    :from (:eval 0) :to :result) tmp)
1305   (:results (y :scs (unsigned-reg) :from (:eval 0)))
1306   (:result-types unsigned-num)
1307   (:generator 50
1308     (inst mov k (make-ea :dword :base state
1309                          :disp (- (* (+ 2 vector-data-offset)
1310                                      n-word-bytes)
1311                                   other-pointer-lowtag)))
1312     (inst cmp k 624)
1313     (inst jmp :ne no-update)
1314     (inst mov tmp state)        ; The state is passed in EAX.
1315     (inst call (make-fixup 'random-mt19937-update :assembly-routine))
1316     ;; Restore k, and set to 0.
1317     (inst xor k k)
1318     NO-UPDATE
1319     ;; y = ptgfsr[k++];
1320     (inst mov y (make-ea :dword :base state :index k :scale 4
1321                          :disp (- (* (+ 3 vector-data-offset)
1322                                      n-word-bytes)
1323                                   other-pointer-lowtag)))
1324     ;; y ^= (y >> 11);
1325     (inst shr y 11)
1326     (inst xor y (make-ea :dword :base state :index k :scale 4
1327                          :disp (- (* (+ 3 vector-data-offset)
1328                                      n-word-bytes)
1329                                   other-pointer-lowtag)))
1330     ;; y ^= (y << 7) & #x9d2c5680
1331     (inst mov tmp y)
1332     (inst inc k)
1333     (inst shl tmp 7)
1334     (inst mov (make-ea :dword :base state
1335                        :disp (- (* (+ 2 vector-data-offset)
1336                                    n-word-bytes)
1337                                 other-pointer-lowtag))
1338           k)
1339     (inst and tmp #x9d2c5680)
1340     (inst xor y tmp)
1341     ;; y ^= (y << 15) & #xefc60000
1342     (inst mov tmp y)
1343     (inst shl tmp 15)
1344     (inst and tmp #xefc60000)
1345     (inst xor y tmp)
1346     ;; y ^= (y >> 18);
1347     (inst mov tmp y)
1348     (inst shr tmp 18)
1349     (inst xor y tmp)))
1350 \f
1351 ;;;; Modular functions
1352 (define-modular-fun +-mod32 (x y) + 32)
1353 (define-vop (fast-+-mod32/unsigned=>unsigned fast-+/unsigned=>unsigned)
1354   (:translate +-mod32))
1355 (define-vop (fast-+-mod32-c/unsigned=>unsigned fast-+-c/unsigned=>unsigned)
1356   (:translate +-mod32))
1357
1358 ;;; logical operations
1359 (define-modular-fun lognot-mod32 (x) lognot 32)
1360 (define-vop (lognot-mod32/unsigned=>unsigned)
1361   (:translate lognot-mod32)
1362   (:args (x :scs (unsigned-reg) :target r
1363             :load-if (not (and (sc-is x unsigned-stack)
1364                                (sc-is r unsigned-stack)
1365                                (location= x r)))))
1366   (:arg-types unsigned-num)
1367   (:results (r :scs (unsigned-reg)
1368                :load-if (not (and (sc-is x unsigned-stack)
1369                                   (sc-is r unsigned-stack)
1370                                   (location= x r)))))
1371   (:result-types unsigned-num)
1372   (:policy :fast-safe)
1373   (:generator 1
1374     (move r x)
1375     (inst not r)))
1376
1377 (define-modular-fun logxor-mod32 (x y) logxor 32)
1378 (define-vop (fast-logxor-mod32/unsigned=>unsigned
1379              fast-logxor/unsigned=>unsigned)
1380   (:translate logxor-mod32))
1381 (define-vop (fast-logxor-mod32-c/unsigned=>unsigned
1382              fast-logxor-c/unsigned=>unsigned)
1383   (:translate logxor-mod32))