use LEA Y, [X+X] instead of LEA Y, [X*2] where appropriate on x86-64
[sbcl.git] / src / compiler / x86-64 / arith.lisp
1 ;;;; the VM definition of arithmetic VOPs for the x86-64
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 64) 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 1
50     (move res x)
51     (inst xor res (fixnumize -1))))
52
53 (define-vop (fast-lognot/signed signed-unop)
54   (:translate lognot)
55   (:generator 2
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 64) 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 64) arithmetic"))
110
111 (define-vop (fast-fixnum-binop-c fast-safe-arith-op)
112   (:args (x :target r :scs (any-reg)
113             :load-if (or (not (typep y '(signed-byte 29)))
114                          (not (sc-is x any-reg control-stack)))))
115   (:info y)
116   (:arg-types tagged-num (:constant fixnum))
117   (:results (r :scs (any-reg)
118                :load-if (or (not (location= x r))
119                             (not (typep y '(signed-byte 29))))))
120   (:result-types tagged-num)
121   (:note "inline fixnum arithmetic"))
122
123 (define-vop (fast-unsigned-binop-c fast-safe-arith-op)
124   (:args (x :target r :scs (unsigned-reg)
125             :load-if (or (not (typep y '(unsigned-byte 31)))
126                          (not (sc-is x unsigned-reg unsigned-stack)))))
127   (:info y)
128   (:arg-types unsigned-num (:constant (unsigned-byte 64)))
129   (:results (r :scs (unsigned-reg)
130                :load-if (or (not (location= x r))
131                             (not (typep y '(unsigned-byte 31))))))
132   (:result-types unsigned-num)
133   (:note "inline (unsigned-byte 64) arithmetic"))
134
135 (define-vop (fast-signed-binop-c fast-safe-arith-op)
136   (:args (x :target r :scs (signed-reg)
137             :load-if (or (not (typep y '(signed-byte 32)))
138                          (not (sc-is x signed-reg signed-stack)))))
139   (:info y)
140   (:arg-types signed-num (:constant (signed-byte 64)))
141   (:results (r :scs (signed-reg)
142                :load-if (or (not (location= x r))
143                             (not (typep y '(signed-byte 32))))))
144   (:result-types signed-num)
145   (:note "inline (signed-byte 64) arithmetic"))
146
147 (macrolet ((define-binop (translate untagged-penalty op)
148              `(progn
149                 (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
150                              fast-fixnum-binop)
151                   (:translate ,translate)
152                   (:generator 2
153                               (move r x)
154                               (inst ,op r y)))
155                 (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
156                              fast-fixnum-binop-c)
157                   (:translate ,translate)
158                   (:generator 1
159                   (move r x)
160                   (inst ,op r (if (typep y '(signed-byte 29))
161                                   (fixnumize y)
162                                   (register-inline-constant :qword (fixnumize y))))))
163                 (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
164                              fast-signed-binop)
165                   (:translate ,translate)
166                   (:generator ,(1+ untagged-penalty)
167                   (move r x)
168                   (inst ,op r y)))
169                 (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
170                              fast-signed-binop-c)
171                   (:translate ,translate)
172                   (:generator ,untagged-penalty
173                   (move r x)
174                   (inst ,op r (if (typep y '(signed-byte 32))
175                                   y
176                                   (register-inline-constant :qword y)))))
177                 (define-vop (,(symbolicate "FAST-"
178                                            translate
179                                            "/UNSIGNED=>UNSIGNED")
180                 fast-unsigned-binop)
181                   (:translate ,translate)
182                   (:generator ,(1+ untagged-penalty)
183                   (move r x)
184                   (inst ,op r y)))
185                 (define-vop (,(symbolicate 'fast-
186                                            translate
187                                            '-c/unsigned=>unsigned)
188                              fast-unsigned-binop-c)
189                   (:translate ,translate)
190                   (:generator ,untagged-penalty
191                   (move r x)
192                   (inst ,op r (if (typep y '(unsigned-byte 31))
193                                   y
194                                   (register-inline-constant :qword y))))))))
195
196   ;;(define-binop + 4 add)
197   (define-binop - 4 sub)
198   (define-binop logand 2 and)
199   (define-binop logior 2 or)
200   (define-binop logxor 2 xor))
201
202 ;;; Special handling of add on the x86; can use lea to avoid a
203 ;;; register load, otherwise it uses add.
204 (define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op)
205   (:translate +)
206   (:args (x :scs (any-reg) :target r
207             :load-if (not (and (sc-is x control-stack)
208                                (sc-is y any-reg)
209                                (sc-is r control-stack)
210                                (location= x r))))
211          (y :scs (any-reg control-stack)))
212   (:arg-types tagged-num tagged-num)
213   (:results (r :scs (any-reg) :from (:argument 0)
214                :load-if (not (and (sc-is x control-stack)
215                                   (sc-is y any-reg)
216                                   (sc-is r control-stack)
217                                   (location= x r)))))
218   (:result-types tagged-num)
219   (:note "inline fixnum arithmetic")
220   (:generator 2
221     (cond ((and (sc-is x any-reg) (sc-is y any-reg) (sc-is r any-reg)
222                 (not (location= x r)))
223            (inst lea r (make-ea :qword :base x :index y :scale 1)))
224           (t
225            (move r x)
226            (inst add r y)))))
227
228 (define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op)
229   (:translate +)
230   (:args (x :target r :scs (any-reg)
231             :load-if (or (not (typep y '(signed-byte 29)))
232                          (not (sc-is x any-reg control-stack)))))
233   (:info y)
234   (:arg-types tagged-num (:constant fixnum))
235   (:results (r :scs (any-reg)
236                :load-if (or (not (location= x r))
237                             (not (typep y '(signed-byte 29))))))
238   (:result-types tagged-num)
239   (:note "inline fixnum arithmetic")
240   (:generator 1
241     (cond ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r))
242                 (typep y '(signed-byte 29)))
243            (inst lea r (make-ea :qword :base x :disp (fixnumize y))))
244           ((typep y '(signed-byte 29))
245            (move r x)
246            (inst add r (fixnumize y)))
247           (t
248            (move r x)
249            (inst add r (register-inline-constant :qword (fixnumize y)))))))
250
251 (define-vop (fast-+/signed=>signed fast-safe-arith-op)
252   (:translate +)
253   (:args (x :scs (signed-reg) :target r
254             :load-if (not (and (sc-is x signed-stack)
255                                (sc-is y signed-reg)
256                                (sc-is r signed-stack)
257                                (location= x r))))
258          (y :scs (signed-reg signed-stack)))
259   (:arg-types signed-num signed-num)
260   (:results (r :scs (signed-reg) :from (:argument 0)
261                :load-if (not (and (sc-is x signed-stack)
262                                   (sc-is y signed-reg)
263                                   (location= x r)))))
264   (:result-types signed-num)
265   (:note "inline (signed-byte 64) arithmetic")
266   (:generator 5
267     (cond ((and (sc-is x signed-reg) (sc-is y signed-reg) (sc-is r signed-reg)
268                 (not (location= x r)))
269            (inst lea r (make-ea :qword :base x :index y :scale 1)))
270           (t
271            (move r x)
272            (inst add r y)))))
273
274
275 ;;;; Special logand cases: (logand signed unsigned) => unsigned
276
277 (define-vop (fast-logand/signed-unsigned=>unsigned
278              fast-logand/unsigned=>unsigned)
279   (:args (x :target r :scs (signed-reg)
280             :load-if (not (and (sc-is x signed-stack)
281                                (sc-is y unsigned-reg)
282                                (sc-is r unsigned-stack)
283                                (location= x r))))
284          (y :scs (unsigned-reg unsigned-stack)))
285   (:arg-types signed-num unsigned-num))
286
287 (define-vop (fast-logand-c/signed-unsigned=>unsigned
288              fast-logand-c/unsigned=>unsigned)
289   (:args (x :target r :scs (signed-reg)
290             :load-if (or (not (typep y '(unsigned-byte 31)))
291                          (not (sc-is r signed-reg signed-stack)))))
292   (:arg-types signed-num (:constant (unsigned-byte 64))))
293
294 (define-vop (fast-logand/unsigned-signed=>unsigned
295              fast-logand/unsigned=>unsigned)
296   (:args (x :target r :scs (unsigned-reg)
297             :load-if (not (and (sc-is x unsigned-stack)
298                                (sc-is y signed-reg)
299                                (sc-is r unsigned-stack)
300                                (location= x r))))
301          (y :scs (signed-reg signed-stack)))
302   (:arg-types unsigned-num signed-num))
303 \f
304
305 (define-vop (fast-+-c/signed=>signed fast-safe-arith-op)
306   (:translate +)
307   (:args (x :target r :scs (signed-reg)
308             :load-if (or (not (typep y '(signed-byte 32)))
309                          (not (sc-is r signed-reg signed-stack)))))
310   (:info y)
311   (:arg-types signed-num (:constant (signed-byte 64)))
312   (:results (r :scs (signed-reg)
313                :load-if (or (not (location= x r))
314                             (not (typep y '(signed-byte 32))))))
315   (:result-types signed-num)
316   (:note "inline (signed-byte 64) arithmetic")
317   (:generator 4
318     (cond ((and (sc-is x signed-reg) (sc-is r signed-reg)
319                 (not (location= x r))
320                 (typep y '(signed-byte 32)))
321            (inst lea r (make-ea :qword :base x :disp y)))
322           (t
323            (move r x)
324            (cond ((= y 1)
325                   (inst inc r))
326                  ((typep y '(signed-byte 32))
327                   (inst add r y))
328                  (t
329                   (inst add r (register-inline-constant :qword y))))))))
330
331 (define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op)
332   (:translate +)
333   (:args (x :scs (unsigned-reg) :target r
334             :load-if (not (and (sc-is x unsigned-stack)
335                                (sc-is y unsigned-reg)
336                                (sc-is r unsigned-stack)
337                                (location= x r))))
338          (y :scs (unsigned-reg unsigned-stack)))
339   (:arg-types unsigned-num unsigned-num)
340   (:results (r :scs (unsigned-reg) :from (:argument 0)
341                :load-if (not (and (sc-is x unsigned-stack)
342                                   (sc-is y unsigned-reg)
343                                   (sc-is r unsigned-stack)
344                                   (location= x r)))))
345   (:result-types unsigned-num)
346   (:note "inline (unsigned-byte 64) arithmetic")
347   (:generator 5
348     (cond ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg)
349                 (sc-is r unsigned-reg) (not (location= x r)))
350            (inst lea r (make-ea :qword :base x :index y :scale 1)))
351           (t
352            (move r x)
353            (inst add r y)))))
354
355 (define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op)
356   (:translate +)
357   (:args (x :target r :scs (unsigned-reg)
358             :load-if (or (not (typep y '(unsigned-byte 31)))
359                          (not (sc-is x unsigned-reg unsigned-stack)))))
360   (:info y)
361   (:arg-types unsigned-num (:constant (unsigned-byte 64)))
362   (:results (r :scs (unsigned-reg)
363                :load-if (or (not (location= x r))
364                             (not (typep y '(unsigned-byte 31))))))
365   (:result-types unsigned-num)
366   (:note "inline (unsigned-byte 64) arithmetic")
367   (:generator 4
368     (cond ((and (sc-is x unsigned-reg) (sc-is r unsigned-reg)
369                 (not (location= x r))
370                 (typep y '(unsigned-byte 31)))
371            (inst lea r (make-ea :qword :base x :disp y)))
372           (t
373            (move r x)
374            (cond ((= y 1)
375                   (inst inc r))
376                  ((typep y '(unsigned-byte 31))
377                   (inst add r y))
378                  (t
379                   (inst add r (register-inline-constant :qword y))))))))
380 \f
381 ;;;; multiplication and division
382
383 (define-vop (fast-*/fixnum=>fixnum fast-safe-arith-op)
384   (:translate *)
385   ;; We need different loading characteristics.
386   (:args (x :scs (any-reg) :target r)
387          (y :scs (any-reg control-stack)))
388   (:arg-types tagged-num tagged-num)
389   (:results (r :scs (any-reg) :from (:argument 0)))
390   (:result-types tagged-num)
391   (:note "inline fixnum arithmetic")
392   (:generator 4
393     (move r x)
394     (inst sar r n-fixnum-tag-bits)
395     (inst imul r y)))
396
397 (define-vop (fast-*-c/fixnum=>fixnum fast-safe-arith-op)
398   (:translate *)
399   ;; We need different loading characteristics.
400   (:args (x :scs (any-reg)
401             :load-if (or (not (typep y '(signed-byte 32)))
402                          (not (sc-is x any-reg control-stack)))))
403   (:info y)
404   (:arg-types tagged-num (:constant fixnum))
405   (:results (r :scs (any-reg)))
406   (:result-types tagged-num)
407   (:note "inline fixnum arithmetic")
408   (:generator 3
409     (cond ((typep y '(signed-byte 32))
410            (inst imul r x y))
411           (t
412            (move r x)
413            (inst imul r (register-inline-constant :qword y))))))
414
415 (define-vop (fast-*/signed=>signed fast-safe-arith-op)
416   (:translate *)
417   ;; We need different loading characteristics.
418   (:args (x :scs (signed-reg) :target r)
419          (y :scs (signed-reg signed-stack)))
420   (:arg-types signed-num signed-num)
421   (:results (r :scs (signed-reg) :from (:argument 0)))
422   (:result-types signed-num)
423   (:note "inline (signed-byte 64) arithmetic")
424   (:generator 5
425     (move r x)
426     (inst imul r y)))
427
428 (define-vop (fast-*-c/signed=>signed fast-safe-arith-op)
429   (:translate *)
430   ;; We need different loading characteristics.
431   (:args (x :scs (signed-reg)
432             :load-if (or (not (typep y '(signed-byte 32)))
433                          (not (sc-is x signed-reg signed-stack)))))
434   (:info y)
435   (:arg-types signed-num (:constant (signed-byte 64)))
436   (:results (r :scs (signed-reg)))
437   (:result-types signed-num)
438   (:note "inline (signed-byte 64) arithmetic")
439   (:generator 4
440     (cond ((typep y '(signed-byte 32))
441            (inst imul r x y))
442           (t
443            (move r x)
444            (inst imul r (register-inline-constant :qword y))))))
445
446 (define-vop (fast-*/unsigned=>unsigned fast-safe-arith-op)
447   (:translate *)
448   (:args (x :scs (unsigned-reg) :target eax)
449          (y :scs (unsigned-reg unsigned-stack)))
450   (:arg-types unsigned-num unsigned-num)
451   (:temporary (:sc unsigned-reg :offset eax-offset :target r
452                    :from (:argument 0) :to :result) eax)
453   (:temporary (:sc unsigned-reg :offset edx-offset
454                    :from :eval :to :result) edx)
455   (:ignore edx)
456   (:results (r :scs (unsigned-reg)))
457   (:result-types unsigned-num)
458   (:note "inline (unsigned-byte 64) arithmetic")
459   (:vop-var vop)
460   (:save-p :compute-only)
461   (:generator 6
462     (move eax x)
463     (inst mul eax y)
464     (move r eax)))
465
466 (define-vop (fast-*-c/unsigned=>unsigned fast-safe-arith-op)
467   (:translate *)
468   (:args (x :scs (unsigned-reg) :target eax))
469   (:info y)
470   (:arg-types unsigned-num (:constant (unsigned-byte 64)))
471   (:temporary (:sc unsigned-reg :offset eax-offset :target r
472                    :from (:argument 0) :to :result) eax)
473   (:temporary (:sc unsigned-reg :offset edx-offset
474                    :from :eval :to :result) edx)
475   (:ignore edx)
476   (:results (r :scs (unsigned-reg)))
477   (:result-types unsigned-num)
478   (:note "inline (unsigned-byte 64) arithmetic")
479   (:vop-var vop)
480   (:save-p :compute-only)
481   (:generator 6
482     (move eax x)
483     (inst mul eax (register-inline-constant :qword y))
484     (move r eax)))
485
486
487 (define-vop (fast-truncate/fixnum=>fixnum fast-safe-arith-op)
488   (:translate truncate)
489   (:args (x :scs (any-reg) :target eax)
490          (y :scs (any-reg control-stack)))
491   (:arg-types tagged-num tagged-num)
492   (:temporary (:sc signed-reg :offset eax-offset :target quo
493                    :from (:argument 0) :to (:result 0)) eax)
494   (:temporary (:sc unsigned-reg :offset edx-offset :target rem
495                    :from (:argument 0) :to (:result 1)) edx)
496   (:results (quo :scs (any-reg))
497             (rem :scs (any-reg)))
498   (:result-types tagged-num tagged-num)
499   (:note "inline fixnum arithmetic")
500   (:vop-var vop)
501   (:save-p :compute-only)
502   (:generator 31
503     (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
504       (if (sc-is y any-reg)
505           (inst test y y)  ; smaller instruction
506           (inst cmp y 0))
507       (inst jmp :eq zero))
508     (move eax x)
509     (inst cqo)
510     (inst idiv eax y)
511     (if (location= quo eax)
512         (inst shl eax n-fixnum-tag-bits)
513         (if (= n-fixnum-tag-bits 1)
514             (inst lea quo (make-ea :qword :base eax :index eax))
515             (inst lea quo (make-ea :qword :index eax
516                                    :scale (ash 1 n-fixnum-tag-bits)))))
517     (move rem edx)))
518
519 (define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
520   (:translate truncate)
521   (:args (x :scs (any-reg) :target eax))
522   (:info y)
523   (:arg-types tagged-num (:constant fixnum))
524   (:temporary (:sc signed-reg :offset eax-offset :target quo
525                    :from :argument :to (:result 0)) eax)
526   (:temporary (:sc any-reg :offset edx-offset :target rem
527                    :from :eval :to (:result 1)) edx)
528   (:temporary (:sc any-reg :from :eval :to :result) y-arg)
529   (:results (quo :scs (any-reg))
530             (rem :scs (any-reg)))
531   (:result-types tagged-num tagged-num)
532   (:note "inline fixnum arithmetic")
533   (:vop-var vop)
534   (:save-p :compute-only)
535   (:generator 30
536     (move eax x)
537     (inst cqo)
538     (if (typep y '(signed-byte 29))
539         (inst mov y-arg (fixnumize y))
540         (setf y-arg (register-inline-constant :qword (fixnumize y))))
541     (inst idiv eax y-arg)
542     (if (location= quo eax)
543         (inst shl eax n-fixnum-tag-bits)
544         (if (= n-fixnum-tag-bits 1)
545             (inst lea quo (make-ea :qword :base eax :index eax))
546             (inst lea quo (make-ea :qword :index eax
547                                    :scale (ash 1 n-fixnum-tag-bits)))))
548     (move rem edx)))
549
550 (define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
551   (:translate truncate)
552   (:args (x :scs (unsigned-reg) :target eax)
553          (y :scs (unsigned-reg signed-stack)))
554   (:arg-types unsigned-num unsigned-num)
555   (:temporary (:sc unsigned-reg :offset eax-offset :target quo
556                    :from (:argument 0) :to (:result 0)) eax)
557   (:temporary (:sc unsigned-reg :offset edx-offset :target rem
558                    :from (:argument 0) :to (:result 1)) edx)
559   (:results (quo :scs (unsigned-reg))
560             (rem :scs (unsigned-reg)))
561   (:result-types unsigned-num unsigned-num)
562   (:note "inline (unsigned-byte 64) arithmetic")
563   (:vop-var vop)
564   (:save-p :compute-only)
565   (:generator 33
566     (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
567       (if (sc-is y unsigned-reg)
568           (inst test y y)  ; smaller instruction
569           (inst cmp y 0))
570       (inst jmp :eq zero))
571     (move eax x)
572     (inst xor edx edx)
573     (inst div eax y)
574     (move quo eax)
575     (move rem edx)))
576
577 (define-vop (fast-truncate-c/unsigned=>unsigned fast-safe-arith-op)
578   (:translate truncate)
579   (:args (x :scs (unsigned-reg) :target eax))
580   (:info y)
581   (:arg-types unsigned-num (:constant (unsigned-byte 64)))
582   (:temporary (:sc unsigned-reg :offset eax-offset :target quo
583                    :from :argument :to (:result 0)) eax)
584   (:temporary (:sc unsigned-reg :offset edx-offset :target rem
585                    :from :eval :to (:result 1)) edx)
586   (:temporary (:sc unsigned-reg :from :eval :to :result) y-arg)
587   (:results (quo :scs (unsigned-reg))
588             (rem :scs (unsigned-reg)))
589   (:result-types unsigned-num unsigned-num)
590   (:note "inline (unsigned-byte 64) arithmetic")
591   (:vop-var vop)
592   (:save-p :compute-only)
593   (:generator 32
594     (move eax x)
595     (inst xor edx edx)
596     (if (typep y '(unsigned-byte 31))
597         (inst mov y-arg y)
598         (setf y-arg (register-inline-constant :qword y)))
599     (inst div eax y-arg)
600     (move quo eax)
601     (move rem edx)))
602
603 (define-vop (fast-truncate/signed=>signed fast-safe-arith-op)
604   (:translate truncate)
605   (:args (x :scs (signed-reg) :target eax)
606          (y :scs (signed-reg signed-stack)))
607   (:arg-types signed-num signed-num)
608   (:temporary (:sc signed-reg :offset eax-offset :target quo
609                    :from (:argument 0) :to (:result 0)) eax)
610   (:temporary (:sc signed-reg :offset edx-offset :target rem
611                    :from (:argument 0) :to (:result 1)) edx)
612   (:results (quo :scs (signed-reg))
613             (rem :scs (signed-reg)))
614   (:result-types signed-num signed-num)
615   (:note "inline (signed-byte 64) arithmetic")
616   (:vop-var vop)
617   (:save-p :compute-only)
618   (:generator 33
619     (let ((zero (generate-error-code vop 'division-by-zero-error x y)))
620       (if (sc-is y signed-reg)
621           (inst test y y)  ; smaller instruction
622           (inst cmp y 0))
623       (inst jmp :eq zero))
624     (move eax x)
625     (inst cqo)
626     (inst idiv eax y)
627     (move quo eax)
628     (move rem edx)))
629
630 (define-vop (fast-truncate-c/signed=>signed fast-safe-arith-op)
631   (:translate truncate)
632   (:args (x :scs (signed-reg) :target eax))
633   (:info y)
634   (:arg-types signed-num (:constant (signed-byte 64)))
635   (:temporary (:sc signed-reg :offset eax-offset :target quo
636                    :from :argument :to (:result 0)) eax)
637   (:temporary (:sc signed-reg :offset edx-offset :target rem
638                    :from :eval :to (:result 1)) edx)
639   (:temporary (:sc signed-reg :from :eval :to :result) y-arg)
640   (:results (quo :scs (signed-reg))
641             (rem :scs (signed-reg)))
642   (:result-types signed-num signed-num)
643   (:note "inline (signed-byte 64) arithmetic")
644   (:vop-var vop)
645   (:save-p :compute-only)
646   (:generator 32
647     (move eax x)
648     (inst cqo)
649     (if (typep y '(signed-byte 32))
650         (inst mov y-arg y)
651         (setf y-arg (register-inline-constant :qword y)))
652     (inst idiv eax y-arg)
653     (move quo eax)
654     (move rem edx)))
655
656
657 \f
658 ;;;; Shifting
659 (define-vop (fast-ash-c/fixnum=>fixnum)
660   (:translate ash)
661   (:policy :fast-safe)
662   (:args (number :scs (any-reg) :target result
663                  :load-if (not (and (sc-is number any-reg control-stack)
664                                     (sc-is result any-reg control-stack)
665                                     (location= number result)))))
666   (:info amount)
667   (:arg-types tagged-num (:constant integer))
668   (:results (result :scs (any-reg)
669                     :load-if (not (and (sc-is number control-stack)
670                                        (sc-is result control-stack)
671                                        (location= number result)))))
672   (:result-types tagged-num)
673   (:note "inline ASH")
674   (:variant nil)
675   (:variant-vars modularp)
676   (:generator 2
677     (cond ((and (= amount 1) (not (location= number result)))
678            (inst lea result (make-ea :qword :base number :index number)))
679           ((and (= amount 2) (not (location= number result)))
680            (inst lea result (make-ea :qword :index number :scale 4)))
681           ((and (= amount 3) (not (location= number result)))
682            (inst lea result (make-ea :qword :index number :scale 8)))
683           (t
684            (move result number)
685            (cond ((< -64 amount 64)
686                   ;; this code is used both in ASH and ASH-MODFX, so
687                   ;; be careful
688                   (if (plusp amount)
689                       (inst shl result amount)
690                       (progn
691                         (inst sar result (- amount))
692                         (inst and result (lognot fixnum-tag-mask)))))
693                  ;; shifting left (zero fill)
694                  ((plusp amount)
695                   (unless modularp
696                     (aver (not "Impossible: fixnum ASH should not be called with
697 constant shift greater than word length")))
698                   (if (sc-is result any-reg)
699                       (zeroize result)
700                       (inst mov result 0)))
701                  ;; shifting right (sign fill)
702                  (t (inst sar result 63)
703                     (inst and result (lognot fixnum-tag-mask))))))))
704
705 (define-vop (fast-ash-left/fixnum=>fixnum)
706   (:translate ash)
707   (:args (number :scs (any-reg) :target result
708                  :load-if (not (and (sc-is number control-stack)
709                                     (sc-is result control-stack)
710                                     (location= number result))))
711          (amount :scs (unsigned-reg) :target ecx))
712   (:arg-types tagged-num positive-fixnum)
713   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
714   (:results (result :scs (any-reg) :from (:argument 0)
715                     :load-if (not (and (sc-is number control-stack)
716                                        (sc-is result control-stack)
717                                        (location= number result)))))
718   (:result-types tagged-num)
719   (:policy :fast-safe)
720   (:note "inline ASH")
721   (:generator 3
722     (move result number)
723     (move ecx amount)
724     ;; The result-type ensures us that this shift will not overflow.
725     (inst shl result :cl)))
726
727 (define-vop (fast-ash-c/signed=>signed)
728   (:translate ash)
729   (:policy :fast-safe)
730   (:args (number :scs (signed-reg) :target result
731                  :load-if (not (and (sc-is number signed-stack)
732                                     (sc-is result signed-stack)
733                                     (location= number result)))))
734   (:info amount)
735   (:arg-types signed-num (:constant integer))
736   (:results (result :scs (signed-reg)
737                     :load-if (not (and (sc-is number signed-stack)
738                                        (sc-is result signed-stack)
739                                        (location= number result)))))
740   (:result-types signed-num)
741   (:note "inline ASH")
742   (:generator 3
743     (cond ((and (= amount 1) (not (location= number result)))
744            (inst lea result (make-ea :qword :base number :index number)))
745           ((and (= amount 2) (not (location= number result)))
746            (inst lea result (make-ea :qword :index number :scale 4)))
747           ((and (= amount 3) (not (location= number result)))
748            (inst lea result (make-ea :qword :index number :scale 8)))
749           (t
750            (move result number)
751            (cond ((plusp amount) (inst shl result amount))
752                  (t (inst sar result (min 63 (- amount)))))))))
753
754 (define-vop (fast-ash-c/unsigned=>unsigned)
755   (:translate ash)
756   (:policy :fast-safe)
757   (:args (number :scs (unsigned-reg) :target result
758                  :load-if (not (and (sc-is number unsigned-stack)
759                                     (sc-is result unsigned-stack)
760                                     (location= number result)))))
761   (:info amount)
762   (:arg-types unsigned-num (:constant integer))
763   (:results (result :scs (unsigned-reg)
764                     :load-if (not (and (sc-is number unsigned-stack)
765                                        (sc-is result unsigned-stack)
766                                        (location= number result)))))
767   (:result-types unsigned-num)
768   (:note "inline ASH")
769   (:generator 3
770     (cond ((and (= amount 1) (not (location= number result)))
771            (inst lea result (make-ea :qword :base number :index number)))
772           ((and (= amount 2) (not (location= number result)))
773            (inst lea result (make-ea :qword :index number :scale 4)))
774           ((and (= amount 3) (not (location= number result)))
775            (inst lea result (make-ea :qword :index number :scale 8)))
776           (t
777            (move result number)
778            (cond ((< -64 amount 64) ;; XXXX
779                   ;; this code is used both in ASH and ASH-MOD32, so
780                   ;; be careful
781                   (if (plusp amount)
782                       (inst shl result amount)
783                       (inst shr result (- amount))))
784                  (t (if (sc-is result unsigned-reg)
785                         (zeroize result)
786                         (inst mov result 0))))))))
787
788 (define-vop (fast-ash-left/signed=>signed)
789   (:translate ash)
790   (:args (number :scs (signed-reg) :target result
791                  :load-if (not (and (sc-is number signed-stack)
792                                     (sc-is result signed-stack)
793                                     (location= number result))))
794          (amount :scs (unsigned-reg) :target ecx))
795   (:arg-types signed-num positive-fixnum)
796   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
797   (:results (result :scs (signed-reg) :from (:argument 0)
798                     :load-if (not (and (sc-is number signed-stack)
799                                        (sc-is result signed-stack)
800                                        (location= number result)))))
801   (:result-types signed-num)
802   (:policy :fast-safe)
803   (:note "inline ASH")
804   (:generator 4
805     (move result number)
806     (move ecx amount)
807     (inst shl result :cl)))
808
809 (define-vop (fast-ash-left/unsigned=>unsigned)
810   (:translate ash)
811   (:args (number :scs (unsigned-reg) :target result
812                  :load-if (not (and (sc-is number unsigned-stack)
813                                     (sc-is result unsigned-stack)
814                                     (location= number result))))
815          (amount :scs (unsigned-reg) :target ecx))
816   (:arg-types unsigned-num positive-fixnum)
817   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
818   (:results (result :scs (unsigned-reg) :from (:argument 0)
819                     :load-if (not (and (sc-is number unsigned-stack)
820                                        (sc-is result unsigned-stack)
821                                        (location= number result)))))
822   (:result-types unsigned-num)
823   (:policy :fast-safe)
824   (:note "inline ASH")
825   (:generator 4
826     (move result number)
827     (move ecx amount)
828     (inst shl result :cl)))
829
830 (define-vop (fast-ash/signed=>signed)
831   (:translate ash)
832   (:policy :fast-safe)
833   (:args (number :scs (signed-reg) :target result)
834          (amount :scs (signed-reg) :target ecx))
835   (:arg-types signed-num signed-num)
836   (:results (result :scs (signed-reg) :from (:argument 0)))
837   (:result-types signed-num)
838   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
839   (:note "inline ASH")
840   (:generator 5
841     (move result number)
842     (move ecx amount)
843     (inst or ecx ecx)
844     (inst jmp :ns POSITIVE)
845     (inst neg ecx)
846     (inst cmp ecx 63)
847     (inst jmp :be OKAY)
848     (inst mov ecx 63)
849     OKAY
850     (inst sar result :cl)
851     (inst jmp DONE)
852
853     POSITIVE
854     ;; The result-type ensures us that this shift will not overflow.
855     (inst shl result :cl)
856
857     DONE))
858
859 (define-vop (fast-ash/unsigned=>unsigned)
860   (:translate ash)
861   (:policy :fast-safe)
862   (:args (number :scs (unsigned-reg) :target result)
863          (amount :scs (signed-reg) :target ecx))
864   (:arg-types unsigned-num signed-num)
865   (:results (result :scs (unsigned-reg) :from (:argument 0)))
866   (:result-types unsigned-num)
867   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
868   (:note "inline ASH")
869   (:generator 5
870     (move result number)
871     (move ecx amount)
872     (inst or ecx ecx)
873     (inst jmp :ns POSITIVE)
874     (inst neg ecx)
875     (inst cmp ecx 63)
876     (inst jmp :be OKAY)
877     (zeroize result)
878     (inst jmp DONE)
879     OKAY
880     (inst shr result :cl)
881     (inst jmp DONE)
882
883     POSITIVE
884     ;; The result-type ensures us that this shift will not overflow.
885     (inst shl result :cl)
886
887     DONE))
888
889 (in-package "SB!C")
890
891 (defknown %lea (integer integer (member 1 2 4 8 16) (signed-byte 64))
892   integer
893   (foldable flushable movable))
894
895 (defoptimizer (%lea derive-type) ((base index scale disp))
896   (when (and (constant-lvar-p scale)
897              (constant-lvar-p disp))
898     (let ((scale (lvar-value scale))
899           (disp (lvar-value disp))
900           (base-type (lvar-type base))
901           (index-type (lvar-type index)))
902       (when (and (numeric-type-p base-type)
903                  (numeric-type-p index-type))
904         (let ((base-lo (numeric-type-low base-type))
905               (base-hi (numeric-type-high base-type))
906               (index-lo (numeric-type-low index-type))
907               (index-hi (numeric-type-high index-type)))
908           (make-numeric-type :class 'integer
909                              :complexp :real
910                              :low (when (and base-lo index-lo)
911                                     (+ base-lo (* index-lo scale) disp))
912                              :high (when (and base-hi index-hi)
913                                      (+ base-hi (* index-hi scale) disp))))))))
914
915 (defun %lea (base index scale disp)
916   (+ base (* index scale) disp))
917
918 (in-package "SB!VM")
919
920 (define-vop (%lea/unsigned=>unsigned)
921   (:translate %lea)
922   (:policy :fast-safe)
923   (:args (base :scs (unsigned-reg))
924          (index :scs (unsigned-reg)))
925   (:info scale disp)
926   (:arg-types unsigned-num unsigned-num
927               (:constant (member 1 2 4 8))
928               (:constant (signed-byte 64)))
929   (:results (r :scs (unsigned-reg)))
930   (:result-types unsigned-num)
931   (:generator 5
932     (inst lea r (make-ea :qword :base base :index index
933                          :scale scale :disp disp))))
934
935 (define-vop (%lea/signed=>signed)
936   (:translate %lea)
937   (:policy :fast-safe)
938   (:args (base :scs (signed-reg))
939          (index :scs (signed-reg)))
940   (:info scale disp)
941   (:arg-types signed-num signed-num
942               (:constant (member 1 2 4 8))
943               (:constant (signed-byte 64)))
944   (:results (r :scs (signed-reg)))
945   (:result-types signed-num)
946   (:generator 4
947     (inst lea r (make-ea :qword :base base :index index
948                          :scale scale :disp disp))))
949
950 (define-vop (%lea/fixnum=>fixnum)
951   (:translate %lea)
952   (:policy :fast-safe)
953   (:args (base :scs (any-reg))
954          (index :scs (any-reg)))
955   (:info scale disp)
956   (:arg-types tagged-num tagged-num
957               (:constant (member 1 2 4 8))
958               (:constant (signed-byte 64)))
959   (:results (r :scs (any-reg)))
960   (:result-types tagged-num)
961   (:generator 3
962     (inst lea r (make-ea :qword :base base :index index
963                          :scale scale :disp disp))))
964
965 ;;; FIXME: before making knowledge of this too public, it needs to be
966 ;;; fixed so that it's actually _faster_ than the non-CMOV version; at
967 ;;; least on my Celeron-XXX laptop, this version is marginally slower
968 ;;; than the above version with branches.  -- CSR, 2003-09-04
969 (define-vop (fast-cmov-ash/unsigned=>unsigned)
970   (:translate ash)
971   (:policy :fast-safe)
972   (:args (number :scs (unsigned-reg) :target result)
973          (amount :scs (signed-reg) :target ecx))
974   (:arg-types unsigned-num signed-num)
975   (:results (result :scs (unsigned-reg) :from (:argument 0)))
976   (:result-types unsigned-num)
977   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
978   (:temporary (:sc any-reg :from (:eval 0) :to (:eval 1)) zero)
979   (:note "inline ASH")
980   (:guard (member :cmov *backend-subfeatures*))
981   (:generator 4
982     (move result number)
983     (move ecx amount)
984     (inst or ecx ecx)
985     (inst jmp :ns POSITIVE)
986     (inst neg ecx)
987     (zeroize zero)
988     (inst shr result :cl)
989     (inst cmp ecx 63)
990     (inst cmov :nbe result zero)
991     (inst jmp DONE)
992
993     POSITIVE
994     ;; The result-type ensures us that this shift will not overflow.
995     (inst shl result :cl)
996
997     DONE))
998 \f
999 (define-vop (signed-byte-64-len)
1000   (:translate integer-length)
1001   (:note "inline (signed-byte 64) integer-length")
1002   (:policy :fast-safe)
1003   (:args (arg :scs (signed-reg) :target res))
1004   (:arg-types signed-num)
1005   (:results (res :scs (unsigned-reg)))
1006   (:result-types unsigned-num)
1007   (:generator 28
1008     (move res arg)
1009     (if (sc-is res unsigned-reg)
1010         (inst test res res)
1011         (inst cmp res 0))
1012     (inst jmp :ge POS)
1013     (inst not res)
1014     POS
1015     (inst bsr res res)
1016     (inst jmp :z ZERO)
1017     (inst inc res)
1018     (inst jmp DONE)
1019     ZERO
1020     (zeroize res)
1021     DONE))
1022
1023 (define-vop (unsigned-byte-64-len)
1024   (:translate integer-length)
1025   (:note "inline (unsigned-byte 64) integer-length")
1026   (:policy :fast-safe)
1027   (:args (arg :scs (unsigned-reg)))
1028   (:arg-types unsigned-num)
1029   (:results (res :scs (unsigned-reg)))
1030   (:result-types unsigned-num)
1031   (:generator 26
1032     (inst bsr res arg)
1033     (inst jmp :z ZERO)
1034     (inst inc res)
1035     (inst jmp DONE)
1036     ZERO
1037     (zeroize res)
1038     DONE))
1039
1040 (define-vop (unsigned-byte-64-count)
1041   (:translate logcount)
1042   (:note "inline (unsigned-byte 64) logcount")
1043   (:policy :fast-safe)
1044   (:args (arg :scs (unsigned-reg) :target result))
1045   (:arg-types unsigned-num)
1046   (:results (result :scs (unsigned-reg)))
1047   (:result-types positive-fixnum)
1048   (:temporary (:sc unsigned-reg) temp)
1049   (:temporary (:sc unsigned-reg) mask)
1050   (:generator 14
1051     ;; See the comments below for how the algorithm works. The tricks
1052     ;; used can be found for example in AMD's software optimization
1053     ;; guide or at "http://www.hackersdelight.org/HDcode/pop.cc" in the
1054     ;; function "pop1", for 32-bit words. The extension to 64 bits is
1055     ;; straightforward.
1056     ;; Calculate 2-bit sums. Note that the value of a two-digit binary
1057     ;; number is the sum of the right digit and twice the left digit.
1058     ;; Thus we can calculate the sum of the two digits by shifting the
1059     ;; left digit to the right position and doing a two-bit subtraction.
1060     ;; This subtraction will never create a borrow and thus can be made
1061     ;; on all 32 2-digit numbers at once.
1062     (move result arg)
1063     (move temp arg)
1064     (inst shr result 1)
1065     (inst mov mask #x5555555555555555)
1066     (inst and result mask)
1067     (inst sub temp result)
1068     ;; Calculate 4-bit sums by straightforward shift, mask and add.
1069     ;; Note that we shift the source operand of the MOV and not its
1070     ;; destination so that the SHR and the MOV can execute in the same
1071     ;; clock cycle.
1072     (inst mov result temp)
1073     (inst shr temp 2)
1074     (inst mov mask #x3333333333333333)
1075     (inst and result mask)
1076     (inst and temp mask)
1077     (inst add result temp)
1078     ;; Calculate 8-bit sums. Since each sum is at most 8, which fits
1079     ;; into 4 bits, we can apply the mask after the addition, saving one
1080     ;; instruction.
1081     (inst mov temp result)
1082     (inst shr result 4)
1083     (inst add result temp)
1084     (inst mov mask #x0f0f0f0f0f0f0f0f)
1085     (inst and result mask)
1086     ;; Add all 8 bytes at once by multiplying with #256r11111111.
1087     ;; We need to calculate only the lower 8 bytes of the product.
1088     ;; Of these the most significant byte contains the final result.
1089     ;; Note that there can be no overflow from one byte to the next
1090     ;; as the sum is at most 64 which needs only 7 bits.
1091     (inst mov mask #x0101010101010101)
1092     (inst imul result mask)
1093     (inst shr result 56)))
1094 \f
1095 ;;;; binary conditional VOPs
1096
1097 (define-vop (fast-conditional)
1098   (:conditional :e)
1099   (:info)
1100   (:effects)
1101   (:affected)
1102   (:policy :fast-safe))
1103
1104 ;;; constant variants are declared for 32 bits not 64 bits, because
1105 ;;; loading a 64 bit constant is silly
1106
1107 (define-vop (fast-conditional/fixnum fast-conditional)
1108   (:args (x :scs (any-reg)
1109             :load-if (not (and (sc-is x control-stack)
1110                                (sc-is y any-reg))))
1111          (y :scs (any-reg control-stack)))
1112   (:arg-types tagged-num tagged-num)
1113   (:note "inline fixnum comparison"))
1114
1115 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
1116   (:args (x :scs (any-reg)
1117             :load-if (or (not (typep y '(signed-byte 29)))
1118                          (not (sc-is x any-reg control-stack)))))
1119   (:arg-types tagged-num (:constant fixnum))
1120   (:info y))
1121
1122 (define-vop (fast-conditional/signed fast-conditional)
1123   (:args (x :scs (signed-reg)
1124             :load-if (not (and (sc-is x signed-stack)
1125                                (sc-is y signed-reg))))
1126          (y :scs (signed-reg signed-stack)))
1127   (:arg-types signed-num signed-num)
1128   (:note "inline (signed-byte 64) comparison"))
1129
1130 (define-vop (fast-conditional-c/signed fast-conditional/signed)
1131   (:args (x :scs (signed-reg)
1132             :load-if (or (not (typep y '(signed-byte 32)))
1133                          (not (sc-is x signed-reg signed-stack)))))
1134   (:arg-types signed-num (:constant (signed-byte 64)))
1135   (:info y))
1136
1137 (define-vop (fast-conditional/unsigned fast-conditional)
1138   (:args (x :scs (unsigned-reg)
1139             :load-if (not (and (sc-is x unsigned-stack)
1140                                (sc-is y unsigned-reg))))
1141          (y :scs (unsigned-reg unsigned-stack)))
1142   (:arg-types unsigned-num unsigned-num)
1143   (:note "inline (unsigned-byte 64) comparison"))
1144
1145 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
1146   (:args (x :scs (unsigned-reg)
1147             :load-if (or (not (typep y '(unsigned-byte 31)))
1148                          (not (sc-is x unsigned-reg unsigned-stack)))))
1149   (:arg-types unsigned-num (:constant (unsigned-byte 64)))
1150   (:info y))
1151
1152 (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
1153              `(progn
1154                 ,@(mapcar
1155                    (lambda (suffix cost signed)
1156                      `(define-vop (;; FIXME: These could be done more
1157                                    ;; cleanly with SYMBOLICATE.
1158                                    ,(intern (format nil "~:@(FAST-IF-~A~A~)"
1159                                                     tran suffix))
1160                                    ,(intern
1161                                      (format nil "~:@(FAST-CONDITIONAL~A~)"
1162                                              suffix)))
1163                         (:translate ,tran)
1164                         (:conditional ,(if signed cond unsigned))
1165                         (:generator ,cost
1166                                     (inst cmp x
1167                                           ,(case suffix
1168                                              (-c/fixnum
1169                                                 `(if (typep y '(signed-byte 29))
1170                                                      (fixnumize y)
1171                                                      (register-inline-constant
1172                                                       :qword (fixnumize y))))
1173                                              (-c/signed
1174                                                 `(if (typep y '(signed-byte 32))
1175                                                      y
1176                                                      (register-inline-constant
1177                                                       :qword y)))
1178                                              (-c/unsigned
1179                                                 `(if (typep y '(unsigned-byte 31))
1180                                                      y
1181                                                      (register-inline-constant
1182                                                       :qword y)))
1183                                              (t 'y))))))
1184                    '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
1185 ;                  '(/fixnum  /signed  /unsigned)
1186                    '(4 3 6 5 6 5)
1187                    '(t t t t nil nil)))))
1188
1189   (define-conditional-vop < :l :b :ge :ae)
1190   (define-conditional-vop > :g :a :le :be))
1191
1192 (define-vop (fast-if-eql/signed fast-conditional/signed)
1193   (:translate eql)
1194   (:generator 6
1195     (inst cmp x y)))
1196
1197 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
1198   (:translate eql)
1199   (:generator 5
1200     (cond ((and (sc-is x signed-reg) (zerop y))
1201            (inst test x x))  ; smaller instruction
1202           ((typep y '(signed-byte 32))
1203            (inst cmp x y))
1204           (t
1205            (inst cmp x (register-inline-constant :qword y))))))
1206
1207 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
1208   (:translate eql)
1209   (:generator 6
1210     (inst cmp x y)))
1211
1212 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
1213   (:translate eql)
1214   (:generator 5
1215     (cond ((and (sc-is x unsigned-reg) (zerop y))
1216            (inst test x x))  ; smaller instruction
1217           ((typep y '(unsigned-byte 31))
1218            (inst cmp x y))
1219           (t
1220            (inst cmp x (register-inline-constant :qword y))))))
1221
1222 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
1223 ;;; known fixnum.
1224
1225 ;;; These versions specify a fixnum restriction on their first arg. We have
1226 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
1227 ;;; the first arg and a higher cost. The reason for doing this is to prevent
1228 ;;; fixnum specific operations from being used on word integers, spuriously
1229 ;;; consing the argument.
1230
1231 (define-vop (fast-eql/fixnum fast-conditional)
1232   (:args (x :scs (any-reg)
1233             :load-if (not (and (sc-is x control-stack)
1234                                (sc-is y any-reg))))
1235          (y :scs (any-reg control-stack)))
1236   (:arg-types tagged-num tagged-num)
1237   (:note "inline fixnum comparison")
1238   (:translate eql)
1239   (:generator 4
1240     (inst cmp x y)))
1241
1242 (define-vop (generic-eql/fixnum fast-eql/fixnum)
1243   (:args (x :scs (any-reg descriptor-reg)
1244             :load-if (not (and (sc-is x control-stack)
1245                                (sc-is y any-reg))))
1246          (y :scs (any-reg control-stack)))
1247   (:arg-types * tagged-num)
1248   (:variant-cost 7))
1249
1250 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
1251   (:args (x :scs (any-reg)
1252             :load-if (or (not (typep y '(signed-byte 29)))
1253                          (not (sc-is x any-reg descriptor-reg control-stack)))))
1254   (:arg-types tagged-num (:constant fixnum))
1255   (:info y)
1256   (:translate eql)
1257   (:generator 2
1258     (cond ((and (sc-is x any-reg descriptor-reg) (zerop y))
1259            (inst test x x))  ; smaller instruction
1260           ((typep y '(signed-byte 29))
1261            (inst cmp x (fixnumize y)))
1262           (t
1263            (inst cmp x (register-inline-constant :qword (fixnumize y)))))))
1264
1265 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
1266   (:args (x :scs (any-reg descriptor-reg)))
1267   (:arg-types * (:constant fixnum))
1268   (:variant-cost 6))
1269 \f
1270 ;;;; 32-bit logical operations
1271
1272 ;;; Only the lower 6 bits of the shift amount are significant.
1273 (define-vop (shift-towards-someplace)
1274   (:policy :fast-safe)
1275   (:args (num :scs (unsigned-reg) :target r)
1276          (amount :scs (signed-reg) :target ecx))
1277   (:arg-types unsigned-num tagged-num)
1278   (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
1279   (:results (r :scs (unsigned-reg) :from (:argument 0)))
1280   (:result-types unsigned-num))
1281
1282 (define-vop (shift-towards-start shift-towards-someplace)
1283   (:translate shift-towards-start)
1284   (:note "SHIFT-TOWARDS-START")
1285   (:generator 1
1286     (move r num)
1287     (move ecx amount)
1288     (inst shr r :cl)))
1289
1290 (define-vop (shift-towards-end shift-towards-someplace)
1291   (:translate shift-towards-end)
1292   (:note "SHIFT-TOWARDS-END")
1293   (:generator 1
1294     (move r num)
1295     (move ecx amount)
1296     (inst shl r :cl)))
1297 \f
1298 ;;;; Modular functions
1299
1300 (defmacro define-mod-binop ((name prototype) function)
1301   `(define-vop (,name ,prototype)
1302        (:args (x :target r :scs (unsigned-reg signed-reg)
1303                  :load-if (not (and (or (sc-is x unsigned-stack)
1304                                         (sc-is x signed-stack))
1305                                     (or (sc-is y unsigned-reg)
1306                                         (sc-is y signed-reg))
1307                                     (or (sc-is r unsigned-stack)
1308                                         (sc-is r signed-stack))
1309                                     (location= x r))))
1310               (y :scs (unsigned-reg signed-reg unsigned-stack signed-stack)))
1311      (:arg-types untagged-num untagged-num)
1312      (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1313                   :load-if (not (and (or (sc-is x unsigned-stack)
1314                                          (sc-is x signed-stack))
1315                                      (or (sc-is y unsigned-reg)
1316                                          (sc-is y unsigned-reg))
1317                                      (or (sc-is r unsigned-stack)
1318                                          (sc-is r unsigned-stack))
1319                                      (location= x r)))))
1320      (:result-types unsigned-num)
1321      (:translate ,function)))
1322 (defmacro define-mod-binop-c ((name prototype) function)
1323   `(define-vop (,name ,prototype)
1324        (:args (x :target r :scs (unsigned-reg signed-reg)
1325                  :load-if (not (and (or (sc-is x unsigned-stack)
1326                                         (sc-is x signed-stack))
1327                                     (or (sc-is r unsigned-stack)
1328                                         (sc-is r signed-stack))
1329                                     (location= x r)
1330                                     (typep y '(signed-byte 32))))))
1331      (:info y)
1332      (:arg-types untagged-num (:constant (or (unsigned-byte 64) (signed-byte 64))))
1333      (:results (r :scs (unsigned-reg signed-reg) :from (:argument 0)
1334                   :load-if (not (and (or (sc-is x unsigned-stack)
1335                                          (sc-is x signed-stack))
1336                                      (or (sc-is r unsigned-stack)
1337                                          (sc-is r unsigned-stack))
1338                                      (location= x r)))))
1339      (:result-types unsigned-num)
1340      (:translate ,function)))
1341
1342 (macrolet ((def (name -c-p)
1343              (let ((fun64 (intern (format nil "~S-MOD64" name)))
1344                    (vopu (intern (format nil "FAST-~S/UNSIGNED=>UNSIGNED" name)))
1345                    (vopcu (intern (format nil "FAST-~S-C/UNSIGNED=>UNSIGNED" name)))
1346                    (vopf (intern (format nil "FAST-~S/FIXNUM=>FIXNUM" name)))
1347                    (vopcf (intern (format nil "FAST-~S-C/FIXNUM=>FIXNUM" name)))
1348                    (vop64u (intern (format nil "FAST-~S-MOD64/WORD=>UNSIGNED" name)))
1349                    (vop64f (intern (format nil "FAST-~S-MOD64/FIXNUM=>FIXNUM" name)))
1350                    (vop64cu (intern (format nil "FAST-~S-MOD64-C/WORD=>UNSIGNED" name)))
1351                    (vop64cf (intern (format nil "FAST-~S-MOD64-C/FIXNUM=>FIXNUM" name)))
1352                    (funfx (intern (format nil "~S-MODFX" name)))
1353                    (vopfxf (intern (format nil "FAST-~S-MODFX/FIXNUM=>FIXNUM" name)))
1354                    (vopfxcf (intern (format nil "FAST-~S-MODFX-C/FIXNUM=>FIXNUM" name))))
1355                `(progn
1356                   (define-modular-fun ,fun64 (x y) ,name :untagged nil 64)
1357                   (define-modular-fun ,funfx (x y) ,name :tagged t
1358                                       #.(- n-word-bits n-fixnum-tag-bits))
1359                   (define-mod-binop (,vop64u ,vopu) ,fun64)
1360                   (define-vop (,vop64f ,vopf) (:translate ,fun64))
1361                   (define-vop (,vopfxf ,vopf) (:translate ,funfx))
1362                   ,@(when -c-p
1363                       `((define-mod-binop-c (,vop64cu ,vopcu) ,fun64)
1364                         (define-vop (,vopfxcf ,vopcf) (:translate ,funfx))))))))
1365   (def + t)
1366   (def - t)
1367   (def * t))
1368
1369 (define-vop (fast-ash-left-mod64-c/unsigned=>unsigned
1370              fast-ash-c/unsigned=>unsigned)
1371   (:translate ash-left-mod64))
1372 (define-vop (fast-ash-left-mod64/unsigned=>unsigned
1373              fast-ash-left/unsigned=>unsigned))
1374 (deftransform ash-left-mod64 ((integer count)
1375                               ((unsigned-byte 64) (unsigned-byte 6)))
1376   (when (sb!c::constant-lvar-p count)
1377     (sb!c::give-up-ir1-transform))
1378   '(%primitive fast-ash-left-mod64/unsigned=>unsigned integer count))
1379
1380 (define-vop (fast-ash-left-modfx-c/fixnum=>fixnum
1381              fast-ash-c/fixnum=>fixnum)
1382   (:variant :modular)
1383   (:translate ash-left-modfx))
1384 (define-vop (fast-ash-left-modfx/fixnum=>fixnum
1385              fast-ash-left/fixnum=>fixnum))
1386 (deftransform ash-left-modfx ((integer count)
1387                               (fixnum (unsigned-byte 6)))
1388   (when (sb!c::constant-lvar-p count)
1389     (sb!c::give-up-ir1-transform))
1390   '(%primitive fast-ash-left-modfx/fixnum=>fixnum integer count))
1391
1392 (in-package "SB!C")
1393
1394 (defknown sb!vm::%lea-mod64 (integer integer (member 1 2 4 8) (signed-byte 64))
1395   (unsigned-byte 64)
1396   (foldable flushable movable))
1397 (defknown sb!vm::%lea-modfx (integer integer (member 1 2 4 8) (signed-byte 64))
1398   fixnum
1399   (foldable flushable movable))
1400
1401 (define-modular-fun-optimizer %lea ((base index scale disp) :untagged nil :width width)
1402   (when (and (<= width 64)
1403              (constant-lvar-p scale)
1404              (constant-lvar-p disp))
1405     (cut-to-width base :untagged width nil)
1406     (cut-to-width index :untagged width nil)
1407     'sb!vm::%lea-mod64))
1408 (define-modular-fun-optimizer %lea ((base index scale disp) :tagged t :width width)
1409   (when (and (<= width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
1410              (constant-lvar-p scale)
1411              (constant-lvar-p disp))
1412     (cut-to-width base :tagged width t)
1413     (cut-to-width index :tagged width t)
1414     'sb!vm::%lea-modfx))
1415
1416 #+sb-xc-host
1417 (progn
1418   (defun sb!vm::%lea-mod64 (base index scale disp)
1419     (ldb (byte 64 0) (%lea base index scale disp)))
1420   (defun sb!vm::%lea-modfx (base index scale disp)
1421     (mask-signed-field (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)
1422                        (%lea base index scale disp))))
1423 #-sb-xc-host
1424 (progn
1425   (defun sb!vm::%lea-mod64 (base index scale disp)
1426     (let ((base (logand base #xffffffffffffffff))
1427           (index (logand index #xffffffffffffffff)))
1428       ;; can't use modular version of %LEA, as we only have VOPs for
1429       ;; constant SCALE and DISP.
1430       (ldb (byte 64 0) (+ base (* index scale) disp))))
1431   (defun sb!vm::%lea-modfx (base index scale disp)
1432     (let* ((fixnum-width (- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits))
1433            (base (mask-signed-field fixnum-width base))
1434            (index (mask-signed-field fixnum-width index)))
1435       ;; can't use modular version of %LEA, as we only have VOPs for
1436       ;; constant SCALE and DISP.
1437       (mask-signed-field fixnum-width (+ base (* index scale) disp)))))
1438
1439 (in-package "SB!VM")
1440
1441 (define-vop (%lea-mod64/unsigned=>unsigned
1442              %lea/unsigned=>unsigned)
1443   (:translate %lea-mod64))
1444 (define-vop (%lea-modfx/fixnum=>fixnum
1445              %lea/fixnum=>fixnum)
1446   (:translate %lea-modfx))
1447
1448 ;;; logical operations
1449 (define-modular-fun lognot-mod64 (x) lognot :untagged nil 64)
1450 (define-vop (lognot-mod64/unsigned=>unsigned)
1451   (:translate lognot-mod64)
1452   (:args (x :scs (unsigned-reg unsigned-stack) :target r
1453             :load-if (not (and (sc-is x unsigned-stack)
1454                                (sc-is r unsigned-stack)
1455                                (location= x r)))))
1456   (:arg-types unsigned-num)
1457   (:results (r :scs (unsigned-reg)
1458                :load-if (not (and (sc-is x unsigned-stack)
1459                                   (sc-is r unsigned-stack)
1460                                   (location= x r)))))
1461   (:result-types unsigned-num)
1462   (:policy :fast-safe)
1463   (:generator 1
1464     (move r x)
1465     (inst not r)))
1466
1467 (define-source-transform logeqv (&rest args)
1468   (if (oddp (length args))
1469       `(logxor ,@args)
1470       `(lognot (logxor ,@args))))
1471 (define-source-transform logandc1 (x y)
1472   `(logand (lognot ,x) ,y))
1473 (define-source-transform logandc2 (x y)
1474   `(logand ,x (lognot ,y)))
1475 (define-source-transform logorc1 (x y)
1476   `(logior (lognot ,x) ,y))
1477 (define-source-transform logorc2 (x y)
1478   `(logior ,x (lognot ,y)))
1479 (define-source-transform lognor (x y)
1480   `(lognot (logior ,x ,y)))
1481 (define-source-transform lognand (x y)
1482   `(lognot (logand ,x ,y)))
1483 \f
1484 ;;;; bignum stuff
1485
1486 (define-vop (bignum-length get-header-data)
1487   (:translate sb!bignum:%bignum-length)
1488   (:policy :fast-safe))
1489
1490 (define-vop (bignum-set-length set-header-data)
1491   (:translate sb!bignum:%bignum-set-length)
1492   (:policy :fast-safe))
1493
1494 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
1495   (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
1496 (define-full-reffer+offset bignum--ref-with-offset * bignum-digits-offset
1497   other-pointer-lowtag (unsigned-reg) unsigned-num
1498   sb!bignum:%bignum-ref-with-offset)
1499 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
1500   (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
1501
1502 (define-vop (digit-0-or-plus)
1503   (:translate sb!bignum:%digit-0-or-plusp)
1504   (:policy :fast-safe)
1505   (:args (digit :scs (unsigned-reg)))
1506   (:arg-types unsigned-num)
1507   (:conditional :ns)
1508   (:generator 3
1509     (inst or digit digit)))
1510
1511
1512 ;;; For add and sub with carry the sc of carry argument is any-reg so
1513 ;;; that it may be passed as a fixnum or word and thus may be 0, 1, or
1514 ;;; 8. This is easy to deal with and may save a fixnum-word
1515 ;;; conversion.
1516 (define-vop (add-w/carry)
1517   (:translate sb!bignum:%add-with-carry)
1518   (:policy :fast-safe)
1519   (:args (a :scs (unsigned-reg) :target result)
1520          (b :scs (unsigned-reg unsigned-stack) :to :eval)
1521          (c :scs (any-reg) :target temp))
1522   (:arg-types unsigned-num unsigned-num positive-fixnum)
1523   (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
1524   (:results (result :scs (unsigned-reg) :from (:argument 0))
1525             (carry :scs (unsigned-reg)))
1526   (:result-types unsigned-num positive-fixnum)
1527   (:generator 4
1528     (move result a)
1529     (move temp c)
1530     (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
1531     (inst adc result b)
1532     (inst mov carry 0)
1533     (inst adc carry carry)))
1534
1535 ;;; Note: the borrow is 1 for no borrow and 0 for a borrow, the opposite
1536 ;;; of the x86-64 convention.
1537 (define-vop (sub-w/borrow)
1538   (:translate sb!bignum:%subtract-with-borrow)
1539   (:policy :fast-safe)
1540   (:args (a :scs (unsigned-reg) :to :eval :target result)
1541          (b :scs (unsigned-reg unsigned-stack) :to :result)
1542          (c :scs (any-reg control-stack)))
1543   (:arg-types unsigned-num unsigned-num positive-fixnum)
1544   (:results (result :scs (unsigned-reg) :from :eval)
1545             (borrow :scs (unsigned-reg)))
1546   (:result-types unsigned-num positive-fixnum)
1547   (:generator 5
1548     (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
1549     (move result a)
1550     (inst sbb result b)
1551     (inst mov borrow 1)
1552     (inst sbb borrow 0)))
1553
1554
1555 (define-vop (bignum-mult-and-add-3-arg)
1556   (:translate sb!bignum:%multiply-and-add)
1557   (:policy :fast-safe)
1558   (:args (x :scs (unsigned-reg) :target eax)
1559          (y :scs (unsigned-reg unsigned-stack))
1560          (carry-in :scs (unsigned-reg unsigned-stack)))
1561   (:arg-types unsigned-num unsigned-num unsigned-num)
1562   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1563                    :to (:result 1) :target lo) eax)
1564   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1565                    :to (:result 0) :target hi) edx)
1566   (:results (hi :scs (unsigned-reg))
1567             (lo :scs (unsigned-reg)))
1568   (:result-types unsigned-num unsigned-num)
1569   (:generator 20
1570     (move eax x)
1571     (inst mul eax y)
1572     (inst add eax carry-in)
1573     (inst adc edx 0)
1574     (move hi edx)
1575     (move lo eax)))
1576
1577 (define-vop (bignum-mult-and-add-4-arg)
1578   (:translate sb!bignum:%multiply-and-add)
1579   (:policy :fast-safe)
1580   (:args (x :scs (unsigned-reg) :target eax)
1581          (y :scs (unsigned-reg unsigned-stack))
1582          (prev :scs (unsigned-reg unsigned-stack))
1583          (carry-in :scs (unsigned-reg unsigned-stack)))
1584   (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1585   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1586                    :to (:result 1) :target lo) eax)
1587   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1588                    :to (:result 0) :target hi) edx)
1589   (:results (hi :scs (unsigned-reg))
1590             (lo :scs (unsigned-reg)))
1591   (:result-types unsigned-num unsigned-num)
1592   (:generator 20
1593     (move eax x)
1594     (inst mul eax y)
1595     (inst add eax prev)
1596     (inst adc edx 0)
1597     (inst add eax carry-in)
1598     (inst adc edx 0)
1599     (move hi edx)
1600     (move lo eax)))
1601
1602
1603 (define-vop (bignum-mult)
1604   (:translate sb!bignum:%multiply)
1605   (:policy :fast-safe)
1606   (:args (x :scs (unsigned-reg) :target eax)
1607          (y :scs (unsigned-reg unsigned-stack)))
1608   (:arg-types unsigned-num unsigned-num)
1609   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
1610                    :to (:result 1) :target lo) eax)
1611   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1612                    :to (:result 0) :target hi) edx)
1613   (:results (hi :scs (unsigned-reg))
1614             (lo :scs (unsigned-reg)))
1615   (:result-types unsigned-num unsigned-num)
1616   (:generator 20
1617     (move eax x)
1618     (inst mul eax y)
1619     (move hi edx)
1620     (move lo eax)))
1621
1622 #!+multiply-high-vops
1623 (define-vop (mulhi)
1624   (:translate sb!kernel:%multiply-high)
1625   (:policy :fast-safe)
1626   (:args (x :scs (unsigned-reg) :target eax)
1627          (y :scs (unsigned-reg unsigned-stack)))
1628   (:arg-types unsigned-num unsigned-num)
1629   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0))
1630               eax)
1631   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
1632                    :to (:result 0) :target hi) edx)
1633   (:results (hi :scs (unsigned-reg)))
1634   (:result-types unsigned-num)
1635   (:generator 20
1636     (move eax x)
1637     (inst mul eax y)
1638     (move hi edx)))
1639
1640 #!+multiply-high-vops
1641 (define-vop (mulhi/fx)
1642   (:translate sb!kernel:%multiply-high)
1643   (:policy :fast-safe)
1644   (:args (x :scs (any-reg) :target eax)
1645          (y :scs (unsigned-reg unsigned-stack)))
1646   (:arg-types positive-fixnum unsigned-num)
1647   (:temporary (:sc any-reg :offset eax-offset :from (:argument 0)) eax)
1648   (:temporary (:sc any-reg :offset edx-offset :from (:argument 1)
1649                    :to (:result 0) :target hi) edx)
1650   (:results (hi :scs (any-reg)))
1651   (:result-types positive-fixnum)
1652   (:generator 15
1653     (move eax x)
1654     (inst mul eax y)
1655     (move hi edx)
1656     (inst and hi (lognot fixnum-tag-mask))))
1657
1658 (define-vop (bignum-lognot lognot-mod64/unsigned=>unsigned)
1659   (:translate sb!bignum:%lognot))
1660
1661 (define-vop (fixnum-to-digit)
1662   (:translate sb!bignum:%fixnum-to-digit)
1663   (:policy :fast-safe)
1664   (:args (fixnum :scs (any-reg control-stack) :target digit))
1665   (:arg-types tagged-num)
1666   (:results (digit :scs (unsigned-reg)
1667                    :load-if (not (and (sc-is fixnum control-stack)
1668                                       (sc-is digit unsigned-stack)
1669                                       (location= fixnum digit)))))
1670   (:result-types unsigned-num)
1671   (:generator 1
1672     (move digit fixnum)
1673     (inst sar digit n-fixnum-tag-bits)))
1674
1675 (define-vop (bignum-floor)
1676   (:translate sb!bignum:%bigfloor)
1677   (:policy :fast-safe)
1678   (:args (div-high :scs (unsigned-reg) :target edx)
1679          (div-low :scs (unsigned-reg) :target eax)
1680          (divisor :scs (unsigned-reg unsigned-stack)))
1681   (:arg-types unsigned-num unsigned-num unsigned-num)
1682   (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
1683                    :to (:result 0) :target quo) eax)
1684   (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
1685                    :to (:result 1) :target rem) edx)
1686   (:results (quo :scs (unsigned-reg))
1687             (rem :scs (unsigned-reg)))
1688   (:result-types unsigned-num unsigned-num)
1689   (:generator 300
1690     (move edx div-high)
1691     (move eax div-low)
1692     (inst div eax divisor)
1693     (move quo eax)
1694     (move rem edx)))
1695
1696 (define-vop (signify-digit)
1697   (:translate sb!bignum:%fixnum-digit-with-correct-sign)
1698   (:policy :fast-safe)
1699   (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
1700   (:arg-types unsigned-num)
1701   (:results (res :scs (any-reg signed-reg)
1702                  :load-if (not (and (sc-is digit unsigned-stack)
1703                                     (sc-is res control-stack signed-stack)
1704                                     (location= digit res)))))
1705   (:result-types signed-num)
1706   (:generator 1
1707     (move res digit)
1708     (when (sc-is res any-reg control-stack)
1709       (inst shl res n-fixnum-tag-bits))))
1710
1711 (define-vop (digit-ashr)
1712   (:translate sb!bignum:%ashr)
1713   (:policy :fast-safe)
1714   (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
1715          (count :scs (unsigned-reg) :target ecx))
1716   (:arg-types unsigned-num positive-fixnum)
1717   (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
1718   (:results (result :scs (unsigned-reg) :from (:argument 0)
1719                     :load-if (not (and (sc-is result unsigned-stack)
1720                                        (location= digit result)))))
1721   (:result-types unsigned-num)
1722   (:generator 2
1723     (move result digit)
1724     (move ecx count)
1725     (inst sar result :cl)))
1726
1727 (define-vop (digit-ashr/c)
1728   (:translate sb!bignum:%ashr)
1729   (:policy :fast-safe)
1730   (:args (digit :scs (unsigned-reg unsigned-stack) :target result))
1731   (:arg-types unsigned-num (:constant (integer 0 63)))
1732   (:info count)
1733   (:results (result :scs (unsigned-reg) :from (:argument 0)
1734                     :load-if (not (and (sc-is result unsigned-stack)
1735                                        (location= digit result)))))
1736   (:result-types unsigned-num)
1737   (:generator 1
1738     (move result digit)
1739     (inst sar result count)))
1740
1741 (define-vop (digit-lshr digit-ashr)
1742   (:translate sb!bignum:%digit-logical-shift-right)
1743   (:generator 1
1744     (move result digit)
1745     (move ecx count)
1746     (inst shr result :cl)))
1747
1748 (define-vop (digit-ashl digit-ashr)
1749   (:translate sb!bignum:%ashl)
1750   (:generator 1
1751     (move result digit)
1752     (move ecx count)
1753     (inst shl result :cl)))
1754 \f
1755 ;;;; static functions
1756
1757 (define-static-fun two-arg-/ (x y) :translate /)
1758
1759 (define-static-fun two-arg-gcd (x y) :translate gcd)
1760 (define-static-fun two-arg-lcm (x y) :translate lcm)
1761
1762 (define-static-fun two-arg-and (x y) :translate logand)
1763 (define-static-fun two-arg-ior (x y) :translate logior)
1764 (define-static-fun two-arg-xor (x y) :translate logxor)
1765
1766
1767 (in-package "SB!C")
1768
1769 (defun *-transformer (y)
1770   (cond
1771     ((= y (ash 1 (integer-length y)))
1772      ;; there's a generic transform for y = 2^k
1773      (give-up-ir1-transform))
1774     ((member y '(3 5 9))
1775      ;; we can do these multiplications directly using LEA
1776      `(%lea x x ,(1- y) 0))
1777     (t
1778      ;; A normal 64-bit multiplication takes 4 cycles on Athlon 64/Opteron.
1779      ;; Optimizing multiplications (other than the above cases) to
1780      ;; shifts/adds/leas gives a maximum improvement of 1 cycle, but requires
1781      ;; quite a lot of hairy code.
1782      (give-up-ir1-transform))))
1783
1784 (deftransform * ((x y)
1785                  ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1786                  (unsigned-byte 64))
1787   "recode as leas, shifts and adds"
1788   (let ((y (lvar-value y)))
1789     (*-transformer y)))
1790 (deftransform sb!vm::*-mod64
1791     ((x y) ((unsigned-byte 64) (constant-arg (unsigned-byte 64)))
1792      (unsigned-byte 64))
1793   "recode as leas, shifts and adds"
1794   (let ((y (lvar-value y)))
1795     (*-transformer y)))
1796
1797 (deftransform * ((x y)
1798                  (fixnum (constant-arg (unsigned-byte 64)))
1799                  fixnum)
1800   "recode as leas, shifts and adds"
1801   (let ((y (lvar-value y)))
1802     (*-transformer y)))
1803 (deftransform sb!vm::*-modfx
1804     ((x y) (fixnum (constant-arg (unsigned-byte 64)))
1805      fixnum)
1806   "recode as leas, shifts and adds"
1807   (let ((y (lvar-value y)))
1808     (*-transformer y)))