arith.lisp 56.2 KB
Newer Older
ram's avatar
ram committed
1
2
3
4
5
6
7
8
9
;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
10
 "$Header: src/compiler/x86/arith.lisp $")
ram's avatar
ram committed
11
12
13
14
15
16
17
18
;;;
;;; **********************************************************************
;;;
;;; This file contains the VM definition arithmetic VOPs for the x86.
;;;
;;; Written by William Lott.
;;;
;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
19
;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,2000.
ram's avatar
ram committed
20
21
22
;;; 

(in-package :x86)
23
(intl:textdomain "cmucl-x86-vm")
ram's avatar
ram committed
24
25
26
27
28
29
30
31
32
33
34
35
36


;;;; Unary operations.

(define-vop (fast-safe-arith-op)
  (:policy :fast-safe)
  (:effects)
  (:affected))


(define-vop (fixnum-unop fast-safe-arith-op)
  (:args (x :scs (any-reg) :target res))
  (:results (res :scs (any-reg)))
37
  (:note _N"inline fixnum arithmetic")
ram's avatar
ram committed
38
39
40
41
42
43
  (:arg-types tagged-num)
  (:result-types tagged-num))

(define-vop (signed-unop fast-safe-arith-op)
  (:args (x :scs (signed-reg) :target res))
  (:results (res :scs (signed-reg)))
44
  (:note _N"inline (signed-byte 32) arithmetic")
ram's avatar
ram committed
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
  (:arg-types signed-num)
  (:result-types signed-num))

(define-vop (fast-negate/fixnum fixnum-unop)
  (:translate %negate)
  (:generator 1
    (move res x)
    (inst neg res)))

(define-vop (fast-negate/signed signed-unop)
  (:translate %negate)
  (:generator 2
    (move res x)
    (inst neg res)))

(define-vop (fast-lognot/fixnum fixnum-unop)
  (:translate lognot)
  (:generator 2
    (move res x)
64
    (inst xor res (fixnumize -1))))
ram's avatar
ram committed
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79

(define-vop (fast-lognot/signed signed-unop)
  (:translate lognot)
  (:generator 1
    (move res x)
    (inst not res)))



;;;; Binary fixnum operations.

;;; Assume that any constant operand is the second arg...

(define-vop (fast-fixnum-binop fast-safe-arith-op)
  (:args (x :target r :scs (any-reg)
80
	    :load-if (not (and (sc-is x control-stack)
ram's avatar
ram committed
81
			       (sc-is y any-reg)
82
			       (sc-is r control-stack)
ram's avatar
ram committed
83
			       (location= x r))))
84
	 (y :scs (any-reg control-stack)))
ram's avatar
ram committed
85
86
  (:arg-types tagged-num tagged-num)
  (:results (r :scs (any-reg) :from (:argument 0)
87
	       :load-if (not (and (sc-is x control-stack)
ram's avatar
ram committed
88
				  (sc-is y any-reg)
89
				  (sc-is r control-stack)
ram's avatar
ram committed
90
91
				  (location= x r)))))
  (:result-types tagged-num)
92
  (:note _N"inline fixnum arithmetic"))
ram's avatar
ram committed
93
94
95
96
97

(define-vop (fast-unsigned-binop fast-safe-arith-op)
  (:args (x :target r :scs (unsigned-reg)
	    :load-if (not (and (sc-is x unsigned-stack)
			       (sc-is y unsigned-reg)
98
			       (sc-is r unsigned-stack)
ram's avatar
ram committed
99
100
101
102
103
104
			       (location= x r))))
	 (y :scs (unsigned-reg unsigned-stack)))
  (:arg-types unsigned-num unsigned-num)
  (:results (r :scs (unsigned-reg) :from (:argument 0)
	    :load-if (not (and (sc-is x unsigned-stack)
			       (sc-is y unsigned-reg)
105
			       (sc-is r unsigned-stack)
ram's avatar
ram committed
106
107
			       (location= x r)))))
  (:result-types unsigned-num)
108
  (:note _N"inline (unsigned-byte 32) arithmetic"))
ram's avatar
ram committed
109
110
111
112
113

(define-vop (fast-signed-binop fast-safe-arith-op)
  (:args (x :target r :scs (signed-reg)
	    :load-if (not (and (sc-is x signed-stack)
			       (sc-is y signed-reg)
114
			       (sc-is r signed-stack)
ram's avatar
ram committed
115
116
117
118
119
120
			       (location= x r))))
	 (y :scs (signed-reg signed-stack)))
  (:arg-types signed-num signed-num)
  (:results (r :scs (signed-reg) :from (:argument 0)
	    :load-if (not (and (sc-is x signed-stack)
			       (sc-is y signed-reg)
121
			       (sc-is r signed-stack)
ram's avatar
ram committed
122
123
			       (location= x r)))))
  (:result-types signed-num)
124
  (:note _N"inline (signed-byte 32) arithmetic"))
ram's avatar
ram committed
125
126

(define-vop (fast-fixnum-binop-c fast-safe-arith-op)
127
  (:args (x :target r :scs (any-reg control-stack)))
ram's avatar
ram committed
128
129
130
131
132
  (:info y)
  (:arg-types tagged-num (:constant (signed-byte 30)))
  (:results (r :scs (any-reg)
	       :load-if (not (location= x r))))
  (:result-types tagged-num)
133
  (:note _N"inline fixnum arithmetic"))
ram's avatar
ram committed
134
135
136
137
138
139
140
141

(define-vop (fast-unsigned-binop-c fast-safe-arith-op)
  (:args (x :target r :scs (unsigned-reg unsigned-stack)))
  (:info y)
  (:arg-types unsigned-num (:constant (unsigned-byte 32)))
  (:results (r :scs (unsigned-reg)
	       :load-if (not (location= x r))))
  (:result-types unsigned-num)
142
  (:note _N"inline (unsigned-byte 32) arithmetic"))
ram's avatar
ram committed
143
144
145
146
147
148
149
150

(define-vop (fast-signed-binop-c fast-safe-arith-op)
  (:args (x :target r :scs (signed-reg signed-stack)))
  (:info y)
  (:arg-types signed-num (:constant (signed-byte 32)))
  (:results (r :scs (signed-reg)
	       :load-if (not (location= x r))))
  (:result-types signed-num)
151
  (:note _N"inline (signed-byte 32) arithmetic"))
ram's avatar
ram committed
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168


(eval-when (compile load eval)

(defmacro define-binop (translate untagged-penalty op)
  `(progn
     (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
		  fast-fixnum-binop)
       (:translate ,translate)
       (:generator 2
	 (move r x)
	 (inst ,op r y)))
     (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
		  fast-fixnum-binop-c)
       (:translate ,translate)
       (:generator 1
	 (move r x)
169
	 (inst ,op r (fixnumize y))))
ram's avatar
ram committed
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
     (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
		  fast-signed-binop)
       (:translate ,translate)
       (:generator ,(1+ untagged-penalty)
	 (move r x)
	 (inst ,op r y)))
     (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
		  fast-signed-binop-c)
       (:translate ,translate)
       (:generator ,untagged-penalty
	 (move r x)
	 (inst ,op r y)))
     (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
		  fast-unsigned-binop)
       (:translate ,translate)
       (:generator ,(1+ untagged-penalty)
	 (move r x)
	 (inst ,op r y)))
     (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
		  fast-unsigned-binop-c)
       (:translate ,translate)
       (:generator ,untagged-penalty
	 (move r x)
	 (inst ,op r y)))))

); eval-when



;(define-binop + 4 add)
(define-binop - 4 sub)
(define-binop logand 2 and)
(define-binop logior 2 or)
(define-binop logxor 2 xor)


;;; Special handling of add on the x86; can use lea to avoid a
;;; register load, otherwise it uses add.
(define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op)
  (:translate +)
210
  (:args (x :scs (any-reg) :target r
211
	    :load-if (not (and (sc-is x control-stack)
ram's avatar
ram committed
212
			       (sc-is y any-reg)
213
			       (sc-is r control-stack)
ram's avatar
ram committed
214
			       (location= x r))))
215
	 (y :scs (any-reg control-stack)))
ram's avatar
ram committed
216
217
  (:arg-types tagged-num tagged-num)
  (:results (r :scs (any-reg) :from (:argument 0)
218
	       :load-if (not (and (sc-is x control-stack)
ram's avatar
ram committed
219
				  (sc-is y any-reg)
220
				  (sc-is r control-stack)
ram's avatar
ram committed
221
222
				  (location= x r)))))
  (:result-types tagged-num)
223
  (:note _N"inline fixnum arithmetic")
ram's avatar
ram committed
224
  (:generator 2
225
226
227
228
229
230
    (cond ((and (sc-is x any-reg) (sc-is y any-reg) (sc-is r any-reg)
		(not (location= x r)))
	   (inst lea r (make-ea :dword :base x :index y :scale 1)))
	  (t
	   (move r x)
	   (inst add r y)))))
ram's avatar
ram committed
231
232
233

(define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op)
  (:translate +)
234
  (:args (x :target r :scs (any-reg control-stack)))
ram's avatar
ram committed
235
236
237
238
239
  (:info y)
  (:arg-types tagged-num (:constant (signed-byte 30)))
  (:results (r :scs (any-reg)
	       :load-if (not (location= x r))))
  (:result-types tagged-num)
240
  (:note _N"inline fixnum arithmetic")
ram's avatar
ram committed
241
  (:generator 1
242
    (cond ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r)))
243
	   (inst lea r (make-ea :dword :base x :disp (fixnumize y))))
244
245
	  (t
	   (move r x)
246
	   (inst add r (fixnumize y))))))
ram's avatar
ram committed
247
248
249

(define-vop (fast-+/signed=>signed fast-safe-arith-op)
  (:translate +)
250
  (:args (x :scs (signed-reg) :target r
ram's avatar
ram committed
251
252
	    :load-if (not (and (sc-is x signed-stack)
			       (sc-is y signed-reg)
253
			       (sc-is r signed-stack)
ram's avatar
ram committed
254
255
256
257
258
259
260
261
			       (location= x r))))
	 (y :scs (signed-reg signed-stack)))
  (:arg-types signed-num signed-num)
  (:results (r :scs (signed-reg) :from (:argument 0)
	       :load-if (not (and (sc-is x signed-stack)
				  (sc-is y signed-reg)
				  (location= x r)))))
  (:result-types signed-num)
262
  (:note _N"inline (signed-byte 32) arithmetic")
ram's avatar
ram committed
263
  (:generator 5
264
265
266
267
268
269
    (cond ((and (sc-is x signed-reg) (sc-is y signed-reg) (sc-is r signed-reg)
		(not (location= x r)))
	   (inst lea r (make-ea :dword :base x :index y :scale 1)))
	  (t
	   (move r x)
	   (inst add r y)))))
ram's avatar
ram committed
270
271
272
273
274
275
276
277
278

(define-vop (fast-+-c/signed=>signed fast-safe-arith-op)
  (:translate +)
  (:args (x :target r :scs (signed-reg signed-stack)))
  (:info y)
  (:arg-types signed-num (:constant (signed-byte 32)))
  (:results (r :scs (signed-reg)
	       :load-if (not (location= x r))))
  (:result-types signed-num)
279
  (:note _N"inline (signed-byte 32) arithmetic")
ram's avatar
ram committed
280
  (:generator 4
281
282
283
284
285
286
287
288
    (cond ((and (sc-is x signed-reg) (sc-is r signed-reg)
		(not (location= x r)))
	   (inst lea r (make-ea :dword :base x :disp y)))
	  (t
	   (move r x)
	   (if (= y 1)
	       (inst inc r)
	     (inst add r y))))))
ram's avatar
ram committed
289
290
291

(define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op)
  (:translate +)
292
  (:args (x :scs (unsigned-reg) :target r
ram's avatar
ram committed
293
294
	    :load-if (not (and (sc-is x unsigned-stack)
			       (sc-is y unsigned-reg)
295
			       (sc-is r unsigned-stack)
ram's avatar
ram committed
296
297
298
299
300
301
			       (location= x r))))
	 (y :scs (unsigned-reg unsigned-stack)))
  (:arg-types unsigned-num unsigned-num)
  (:results (r :scs (unsigned-reg) :from (:argument 0)
	       :load-if (not (and (sc-is x unsigned-stack)
				  (sc-is y unsigned-reg)
302
				  (sc-is r unsigned-stack)
ram's avatar
ram committed
303
304
				  (location= x r)))))
  (:result-types unsigned-num)
305
  (:note _N"inline (unsigned-byte 32) arithmetic")
ram's avatar
ram committed
306
  (:generator 5
307
308
309
310
311
312
    (cond ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg)
		(sc-is r unsigned-reg) (not (location= x r)))
	   (inst lea r (make-ea :dword :base x :index y :scale 1)))
	  (t
	   (move r x)
	   (inst add r y)))))
ram's avatar
ram committed
313
314
315
316
317
318
319
320
321

(define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op)
  (:translate +)
  (:args (x :target r :scs (unsigned-reg unsigned-stack)))
  (:info y)
  (:arg-types unsigned-num (:constant (unsigned-byte 32)))
  (:results (r :scs (unsigned-reg)
	       :load-if (not (location= x r))))
  (:result-types unsigned-num)
322
  (:note _N"inline (unsigned-byte 32) arithmetic")
ram's avatar
ram committed
323
  (:generator 4
324
325
326
327
    (cond ((and (sc-is x unsigned-reg)
		(sc-is r unsigned-reg)
		(not (location= x r))
		(valid-displacement-p y))
328
329
330
331
332
	   (inst lea r (make-ea :dword :base x :disp y)))
	  (t
	   (move r x)
	   (if (= y 1)
	       (inst inc r)
333
	       (inst add r y))))))
ram's avatar
ram committed
334

335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350

;;;; Special logand cases: (logand signed unsigned) => unsigned

(define-vop (fast-logand/signed-unsigned=>unsigned
	     fast-logand/unsigned=>unsigned)
  (:args (x :target r :scs (signed-reg)
	    :load-if (not (and (sc-is x signed-stack)
			       (sc-is y unsigned-reg)
			       (sc-is r unsigned-stack)
			       (location= x r))))
	 (y :scs (unsigned-reg unsigned-stack)))
  (:arg-types signed-num unsigned-num))

(define-vop (fast-logand-c/signed-unsigned=>unsigned
	     fast-logand-c/unsigned=>unsigned)
  (:args (x :target r :scs (signed-reg signed-stack)))
351
352
353
354
355
356
357
358
359
360
361
362
  (:arg-types signed-num (:constant (unsigned-byte 32)))
  (:generator 1
    (cond ((and (= y #xffffffff)
		(sc-is x signed-reg))
	   ;; Just move x to the result if we're and'ing with all
	   ;; ones, which doesn't change the bits.
	   (unless (location= x r)
	     (move r x)))
	  (t
	   (move r x)
	   (inst and r y)))))
	   
363
364
365
366
367
368
369
370
371
372
(define-vop (fast-logand/unsigned-signed=>unsigned
	     fast-logand/unsigned=>unsigned)
  (:args (x :target r :scs (unsigned-reg)
	    :load-if (not (and (sc-is x unsigned-stack)
			       (sc-is y signed-reg)
			       (sc-is r unsigned-stack)
			       (location= x r))))
	 (y :scs (signed-reg signed-stack)))
  (:arg-types unsigned-num signed-num))

ram's avatar
ram committed
373
374
375
376
377
378

;;;; Multiplication and division.

(define-vop (fast-*/fixnum=>fixnum fast-safe-arith-op)
  (:translate *)
  ;; We need different loading characteristics.
379
  (:args (x :scs (any-reg) :target r)
380
	 (y :scs (any-reg control-stack)))
ram's avatar
ram committed
381
382
383
  (:arg-types tagged-num tagged-num)
  (:results (r :scs (any-reg) :from (:argument 0)))
  (:result-types tagged-num)
384
  (:note _N"inline fixnum arithmetic")
385
  (:generator 4
ram's avatar
ram committed
386
387
388
389
    (move r x)
    (inst sar r 2)
    (inst imul r y)))

390
(define-vop (fast-*-c/fixnum=>fixnum fast-safe-arith-op)
ram's avatar
ram committed
391
392
  (:translate *)
  ;; We need different loading characteristics.
393
  (:args (x :scs (any-reg control-stack)))
ram's avatar
ram committed
394
395
396
397
  (:info y)
  (:arg-types tagged-num (:constant (signed-byte 30)))
  (:results (r :scs (any-reg)))
  (:result-types tagged-num)
398
  (:note _N"inline fixnum arithmetic")
399
  (:generator 3
ram's avatar
ram committed
400
401
402
403
404
    (inst imul r x y)))

(define-vop (fast-*/signed=>signed fast-safe-arith-op)
  (:translate *)
  ;; We need different loading characteristics.
405
  (:args (x :scs (signed-reg) :target r)
ram's avatar
ram committed
406
407
408
409
	 (y :scs (signed-reg signed-stack)))
  (:arg-types signed-num signed-num)
  (:results (r :scs (signed-reg) :from (:argument 0)))
  (:result-types signed-num)
410
  (:note _N"inline (signed-byte 32) arithmetic")
411
  (:generator 5
ram's avatar
ram committed
412
413
414
    (move r x)
    (inst imul r y)))

415
(define-vop (fast-*-c/signed=>signed fast-safe-arith-op)
ram's avatar
ram committed
416
417
  (:translate *)
  ;; We need different loading characteristics.
418
  (:args (x :scs (signed-reg signed-stack)))
ram's avatar
ram committed
419
420
421
422
  (:info y)
  (:arg-types signed-num (:constant (signed-byte 32)))
  (:results (r :scs (signed-reg)))
  (:result-types signed-num)
423
  (:note _N"inline (signed-byte 32) arithmetic")
424
  (:generator 4
ram's avatar
ram committed
425
426
    (inst imul r x y)))

427
428
(define-vop (fast-*/unsigned=>unsigned fast-safe-arith-op)
  (:translate *)
429
  (:args (x :scs (unsigned-reg) :target r)
430
431
	 (y :scs (unsigned-reg unsigned-stack)))
  (:arg-types unsigned-num unsigned-num)
432
  (:results (r :scs (unsigned-reg) :from (:argument 0)))
433
  (:result-types unsigned-num)
434
  (:note _N"inline (unsigned-byte 32) arithmetic")
435
  (:save-p :compute-only)
436
437
438
  (:generator 5
    (move r x)
    (inst imul r y)))
439
440
441
442

(define-vop (fast-truncate/fixnum=>fixnum fast-safe-arith-op)
  (:translate truncate)
  (:args (x :scs (any-reg) :target eax)
443
	 (y :scs (any-reg control-stack)))
444
  (:arg-types tagged-num tagged-num)
445
  (:temporary (:sc signed-reg :offset eax-offset :target quo
446
		   :from (:argument 0) :to (:result 0)) eax)
447
  (:temporary (:sc unsigned-reg :offset edx-offset :target rem
448
449
450
451
		   :from (:argument 0) :to (:result 1)) edx)
  (:results (quo :scs (any-reg))
	    (rem :scs (any-reg)))
  (:result-types tagged-num tagged-num)
452
  (:note _N"inline fixnum arithmetic")
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 31
    (let ((zero (generate-error-code vop division-by-zero-error x y)))
      (if (sc-is y any-reg)
	  (inst test y y)  ; Smaller instruction
	  (inst cmp y 0))
      (inst jmp :eq zero))
    (move eax x)
    (inst cdq)
    (inst idiv eax y)
    (if (location= quo eax)
	(inst shl eax 2)
	(inst lea quo (make-ea :dword :index eax :scale 4)))
    (move rem edx)))

469
#+nil
470
471
472
473
474
(define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
  (:translate truncate)
  (:args (x :scs (any-reg) :target eax))
  (:info y)
  (:arg-types tagged-num (:constant (signed-byte 30)))
475
  (:temporary (:sc signed-reg :offset eax-offset :target quo
476
477
478
479
480
481
482
		   :from :argument :to (:result 0)) eax)
  (:temporary (:sc any-reg :offset edx-offset :target rem
		   :from :eval :to (:result 1)) edx)
  (:temporary (:sc any-reg :from :eval :to :result) y-arg)
  (:results (quo :scs (any-reg))
	    (rem :scs (any-reg)))
  (:result-types tagged-num tagged-num)
483
  (:note _N"inline fixnum arithmetic")
484
485
486
487
488
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 30
    (move eax x)
    (inst cdq)
489
    (inst mov y-arg (fixnumize y))
490
491
492
493
494
495
496
497
498
499
500
    (inst idiv eax y-arg)
    (if (location= quo eax)
	(inst shl eax 2)
	(inst lea quo (make-ea :dword :index eax :scale 4)))
    (move rem edx)))

(define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
  (:translate truncate)
  (:args (x :scs (unsigned-reg) :target eax)
	 (y :scs (unsigned-reg signed-stack)))
  (:arg-types unsigned-num unsigned-num)
501
  (:temporary (:sc unsigned-reg :offset eax-offset :target quo
502
		   :from (:argument 0) :to (:result 0)) eax)
503
  (:temporary (:sc unsigned-reg :offset edx-offset :target rem
504
505
506
507
		   :from (:argument 0) :to (:result 1)) edx)
  (:results (quo :scs (unsigned-reg))
	    (rem :scs (unsigned-reg)))
  (:result-types unsigned-num unsigned-num)
508
  (:note _N"inline (unsigned-byte 32) arithmetic")
509
510
511
512
513
514
515
516
517
518
519
520
521
522
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 33
    (let ((zero (generate-error-code vop division-by-zero-error x y)))
      (if (sc-is y unsigned-reg)
	  (inst test y y)  ; Smaller instruction
	  (inst cmp y 0))
      (inst jmp :eq zero))
    (move eax x)
    (inst xor edx edx)
    (inst div eax y)
    (move quo eax)
    (move rem edx)))

523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
(define-vop (fast-truncate-c/unsigned=>unsigned fast-unsigned-binop-c)
  (:translate truncate)
  (:args (x :scs (unsigned-reg)))
  (:info y)
  (:arg-types unsigned-num (:constant (integer 2 #.(1- (ash 1 vm:word-bits)))))
  (:results (r :scs (unsigned-reg))
            (rem :scs (unsigned-reg)))
  (:result-types unsigned-num unsigned-num)
  (:note "inline (unsigned-byte 32) arithmetic")
  (:temporary (:sc unsigned-reg :offset edx-offset) edx)
  (:temporary (:sc unsigned-reg :offset eax-offset) eax)
  (:generator 6
    (multiple-value-bind (recip shift overflowp)
        (c::find-unsigned-reciprocal y vm:word-bits)
      ;; q = floor(M*x/2^32)
      (inst mov eax recip)
      (inst mul eax x)			; edx:eax = x*recip
      (cond (overflowp
	     ;; The case where the sum overflows.  X86 has a rotate
	     ;; with carry instruction so use that to get the MSB of
	     ;; the sum and then a regular shift to get the correct
	     ;; number of shifts.
	     (inst add edx x)
	     (inst rcr edx 1)
	     (when (> shift 1)
	       (inst shr edx (1- shift))))
            (t
             ;; The easy case
             (unless (zerop shift)
               (inst shr edx shift))))
      ;; Compute the remainder
      (move rem x)			; Save x in case r is the same tn
      (move r edx)
      (move eax edx)
      (inst mov edx y)
      (inst mul eax edx)
      (inst sub rem eax))))

ram's avatar
ram committed
561
562
(define-vop (fast-truncate/signed=>signed fast-safe-arith-op)
  (:translate truncate)
563
  (:args (x :scs (signed-reg) :target eax)
ram's avatar
ram committed
564
565
	 (y :scs (signed-reg signed-stack)))
  (:arg-types signed-num signed-num)
566
  (:temporary (:sc signed-reg :offset eax-offset :target quo
567
		   :from (:argument 0) :to (:result 0)) eax)
568
  (:temporary (:sc signed-reg :offset edx-offset :target rem
569
		   :from (:argument 0) :to (:result 1)) edx)
570
571
  (:results (quo :scs (signed-reg))
	    (rem :scs (signed-reg)))
ram's avatar
ram committed
572
  (:result-types signed-num signed-num)
573
  (:note _N"inline (signed-byte 32) arithmetic")
ram's avatar
ram committed
574
575
  (:vop-var vop)
  (:save-p :compute-only)
576
  (:generator 33
ram's avatar
ram committed
577
    (let ((zero (generate-error-code vop division-by-zero-error x y)))
578
579
580
      (if (sc-is y signed-reg)
	  (inst test y y)  ; Smaller instruction
	  (inst cmp y 0))
ram's avatar
ram committed
581
582
583
584
585
586
587
      (inst jmp :eq zero))
    (move eax x)
    (inst cdq)
    (inst idiv eax y)
    (move quo eax)
    (move rem edx)))

588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
(define-vop (fast-truncate-c/signed=>signed fast-signed-binop-c)
  (:translate truncate)
  (:args (x :scs (signed-reg)))
  (:info y)
  (:arg-types signed-num (:constant (integer 2 #.(1- (ash 1 vm:word-bits)))))
  (:results (r :scs (signed-reg))
            (rem :scs (signed-reg)))
  (:result-types signed-num signed-num)
  (:note "inline (signed-byte 32) arithmetic")
  (:temporary (:sc signed-reg :offset edx-offset) edx)
  (:temporary (:sc signed-reg :offset eax-offset) eax)
  (:generator 13
    (multiple-value-bind (recip shift)
        (c::find-signed-reciprocal y vm:word-bits)
      ;; Compute q = floor(M*n/2^32).  That is, the high half of the
      ;; product.
      (inst mov eax recip)
      (inst imul x)			; edx:eax = x * recip
      ;; Adjust if the M is negative.
      (when (minusp recip)
        (inst add edx x))
      ;; Shift quotient as needed.
      (unless (zerop shift)
	(inst sar edx shift))
      ;; Add one to quotient if X is negative.  This is done by right
      ;; shifting X to give either -1 or 0.  Then subtract this from
      ;; the quotient.  (NOTE: in the book, the sample code has this
      ;; wrong and ADDS instead of SUBTRACTS.)
      (move eax x)
      (inst sar eax 31)
      (inst sub edx eax)

      ;; Now compute the remainder.
      (move rem x)
      (move r edx)			; Save quotient for return
      (inst imul edx y)			; edx = q * y
      (inst sub rem edx))))
ram's avatar
ram committed
625
626
627


;;;; Shifting
628
629
630
631
(define-vop (fast-ash-c/fixnum=>fixnum)
  (:translate ash)
  (:policy :fast-safe)
  (:args (number :scs (any-reg) :target result
632
633
		 :load-if (not (and (sc-is number any-reg control-stack)
				    (sc-is result any-reg control-stack)
634
635
636
637
				    (location= number result)))))
  (:info amount)
  (:arg-types tagged-num (:constant integer))
  (:results (result :scs (any-reg)
638
639
		    :load-if (not (and (sc-is number control-stack)
				       (sc-is result control-stack)
640
641
				       (location= number result)))))
  (:result-types tagged-num)
642
  (:note _N"inline ASH")
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
  (:generator 2
    (cond ((and (= amount 1) (not (location= number result)))
	   (inst lea result (make-ea :dword :index number :scale 2)))
	  ((and (= amount 2) (not (location= number result)))
	   (inst lea result (make-ea :dword :index number :scale 4)))
	  ((and (= amount 3) (not (location= number result)))
	   (inst lea result (make-ea :dword :index number :scale 8)))
	  (t
	   (move result number)
	   (cond ((plusp amount)
		  ;; We don't have to worry about overflow because of the
		  ;; result type restriction.
		  (inst shl result amount))
		 (t
		  ;; If the amount is greater than 31, only shift by 31.  We
		  ;; have to do this because the shift instructions only look
		  ;; at the low five bits of the result.
		  (inst sar result (min 31 (- amount)))
		  ;; Fixnum correction.
		  (inst and result #xfffffffc)))))))

(define-vop (fast-ash-left/fixnum=>fixnum)
  (:translate ash)
  (:args (number :scs (any-reg) :target result
667
668
		 :load-if (not (and (sc-is number control-stack)
				    (sc-is result control-stack)
669
670
671
				    (location= number result))))
	 (amount :scs (unsigned-reg) :target ecx))
  (:arg-types tagged-num positive-fixnum)
672
  (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
673
  (:results (result :scs (any-reg) :from (:argument 0)
674
675
		    :load-if (not (and (sc-is number control-stack)
				       (sc-is result control-stack)
676
677
				       (location= number result)))))
  (:result-types tagged-num)
ram's avatar
ram committed
678
  (:policy :fast-safe)
679
  (:note _N"inline ASH")
680
681
682
683
684
685
  (:generator 3
    (move result number)
    (move ecx amount)
    ;; The result-type assures us that this shift will not overflow.
    (inst shl result :cl)))

686
(define-vop (fast-ash-c/unsigned=>unsigned)
687
	    (:translate ash)
688
  (:policy :fast-safe)
689
690
691
  (:args (number :scs (unsigned-reg) :target result
		 :load-if (not (and (sc-is number unsigned-stack)
				    (sc-is result unsigned-stack)
692
				    (location= number result)))))
ram's avatar
ram committed
693
  (:info amount)
694
695
696
697
698
699
  (:arg-types unsigned-num (:constant integer))
  (:results (result :scs (unsigned-reg)
		    :load-if (not (and (sc-is number unsigned-stack)
				       (sc-is result unsigned-stack)
				       (location= number result)))))
  (:result-types unsigned-num)
700
  (:note _N"inline ASH")
701
702
  (:generator 3
    (cond ((and (= amount 1) (not (location= number result)))
ram's avatar
ram committed
703
	   (inst lea result (make-ea :dword :index number :scale 2)))
704
	  ((and (= amount 2) (not (location= number result)))
ram's avatar
ram committed
705
	   (inst lea result (make-ea :dword :index number :scale 4)))
706
	  ((and (= amount 3) (not (location= number result)))
ram's avatar
ram committed
707
708
709
710
711
712
713
	   (inst lea result (make-ea :dword :index number :scale 8)))
	  (t
	   (move result number)
	   (cond ((plusp amount)
		  ;; We don't have to worry about overflow because of the
		  ;; result type restriction.
		  (inst shl result amount))
714
715
		 ((< amount -31)
		  (inst mov result 0))
716
		 (t
717
		  (inst shr result (- amount))))))))
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732

(define-vop (fast-ash-c/signed=>signed)
  (:translate ash)
  (:policy :fast-safe)
  (:args (number :scs (signed-reg) :target result
		 :load-if (not (and (sc-is number signed-stack)
				    (sc-is result signed-stack)
				    (location= number result)))))
  (:info amount)
  (:arg-types signed-num (:constant integer))
  (:results (result :scs (signed-reg)
		    :load-if (not (and (sc-is number signed-stack)
				       (sc-is result signed-stack)
				       (location= number result)))))
  (:result-types signed-num)
733
  (:note _N"inline ASH")
734
735
736
737
738
739
740
741
742
743
744
745
746
747
  (:generator 3
    (cond ((and (= amount 1) (not (location= number result)))
	   (inst lea result (make-ea :dword :index number :scale 2)))
	  ((and (= amount 2) (not (location= number result)))
	   (inst lea result (make-ea :dword :index number :scale 4)))
	  ((and (= amount 3) (not (location= number result)))
	   (inst lea result (make-ea :dword :index number :scale 8)))
	  (t
	   (move result number)
	   (cond ((plusp amount)
		  ;; We don't have to worry about overflow because of the
		  ;; result type restriction.
		  (inst shl result amount))
		 (t
ram's avatar
ram committed
748
749
750
		  ;; If the amount is greater than 31, only shift by 31.  We
		  ;; have to do this because the shift instructions only look
		  ;; at the low five bits of the result.
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
		  (inst sar result (min 31 (- amount)))))))))

(define-vop (fast-ash-left/unsigned=>unsigned)
  (:translate ash)
  (:args (number :scs (unsigned-reg) :target result
		 :load-if (not (and (sc-is number unsigned-stack)
				    (sc-is result unsigned-stack)
				    (location= number result))))
	 (amount :scs (unsigned-reg) :target ecx))
  (:arg-types unsigned-num positive-fixnum)
  (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
  (:results (result :scs (unsigned-reg) :from (:argument 0)
		    :load-if (not (and (sc-is number unsigned-stack)
				       (sc-is result unsigned-stack)
				       (location= number result)))))
  (:result-types unsigned-num)
  (:policy :fast-safe)
768
  (:note _N"inline ASH")
769
770
771
772
773
  (:generator 4
    (move result number)
    (move ecx amount)
    ;; The result-type assures us that this shift will not overflow.
    (inst shl result :cl)))
ram's avatar
ram committed
774

775
(define-vop (fast-ash-left/signed=>signed)
776
  (:translate ash)
777
778
779
  (:args (number :scs (signed-reg) :target result
		 :load-if (not (and (sc-is number signed-stack)
				    (sc-is result signed-stack)
780
				    (location= number result))))
ram's avatar
ram committed
781
	 (amount :scs (unsigned-reg) :target ecx))
782
  (:arg-types signed-num positive-fixnum)
783
  (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
784
785
786
787
788
  (:results (result :scs (signed-reg) :from (:argument 0)
		    :load-if (not (and (sc-is number signed-stack)
				       (sc-is result signed-stack)
				       (location= number result)))))
  (:result-types signed-num)
ram's avatar
ram committed
789
  (:policy :fast-safe)
790
  (:note _N"inline ASH")
791
  (:generator 4
ram's avatar
ram committed
792
793
794
795
796
    (move result number)
    (move ecx amount)
    ;; The result-type assures us that this shift will not overflow.
    (inst shl result :cl)))

797
(define-vop (fast-ash/unsigned=>unsigned)
798
	    (:translate ash)
799
  (:policy :fast-safe)
800
  (:args (number :scs (unsigned-reg) :target result)
ram's avatar
ram committed
801
	 (amount :scs (signed-reg) :target ecx))
802
803
804
  (:arg-types unsigned-num signed-num)
  (:results (result :scs (unsigned-reg) :from (:argument 0)))
  (:result-types unsigned-num)
805
  (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
806
  (:note _N"inline ASH")
ram's avatar
ram committed
807
808
  (:generator 5
    (move result number)
809
    (move ecx amount)
ram's avatar
ram committed
810
    (inst or ecx ecx)
811
    (inst jmp :ns POSITIVE)
ram's avatar
ram committed
812
813
    (inst neg ecx)
    (inst cmp ecx 31)
814
815
816
    (inst jmp :be OKAY)
    (inst xor result result)
    (inst jmp DONE)
ram's avatar
ram committed
817
    OKAY
818
    (inst shr result :cl)
819
820
    (inst jmp DONE)
    
ram's avatar
ram committed
821
822
823
    POSITIVE
    ;; The result-type assures us that this shift will not overflow.
    (inst shl result :cl)
824
    
ram's avatar
ram committed
825
826
    DONE))

827
828
829
830
831
832
833
834
835
(define-vop (fast-ash/signed=>signed)
  (:translate ash)
  (:policy :fast-safe)
  (:args (number :scs (signed-reg) :target result)
	 (amount :scs (signed-reg) :target ecx))
  (:arg-types signed-num signed-num)
  (:results (result :scs (signed-reg) :from (:argument 0)))
  (:result-types signed-num)
  (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
836
  (:note _N"inline ASH")
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
  (:generator 5
    (move result number)
    (move ecx amount)
    (inst or ecx ecx)
    (inst jmp :ns positive)
    (inst neg ecx)
    (inst cmp ecx 31)
    (inst jmp :be okay)
    (inst mov ecx 31)
    OKAY
    (inst sar result :cl)
    (inst jmp done)
      
    POSITIVE
    ;; The result-type assures us that this shift will not overflow.
    (inst shl result :cl)
      
    DONE))
855

ram's avatar
ram committed
856
857
858
859

;;; note documentation for this function is wrong - rtfm
(define-vop (signed-byte-32-len)
  (:translate integer-length)
860
  (:note _N"inline (signed-byte 32) integer-length")
ram's avatar
ram committed
861
  (:policy :fast-safe)
862
  (:args (arg :scs (signed-reg) :target res))
ram's avatar
ram committed
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
  (:arg-types signed-num)
  (:results (res :scs (any-reg)))
  (:result-types positive-fixnum)
  (:generator 30
    (move res arg)
    (inst cmp res 0)
    (inst jmp :ge POS)
    (inst not res)
    POS
    (inst bsr res res)
    (inst jmp :z zero)
    (inst inc res)
    (inst shl res 2)
    (inst jmp done)
    ZERO
    (inst xor res res)
    DONE))

(define-vop (unsigned-byte-32-count)
  (:translate logcount)
883
  (:note _N"inline (unsigned-byte 32) logcount")
ram's avatar
ram committed
884
885
886
887
888
  (:policy :fast-safe)
  (:args (arg :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:results (result :scs (unsigned-reg)))
  (:result-types positive-fixnum)
889
  (:temporary (:sc unsigned-reg :from (:argument 0)) temp)
ram's avatar
ram committed
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
  (:generator 30
    (move result arg)

    (inst mov temp result)
    (inst shr temp 1)
    (inst and result #x55555555)
    (inst and temp #x55555555)
    (inst add result temp)

    (inst mov temp result)
    (inst shr temp 2)
    (inst and result #x33333333)
    (inst and temp #x33333333)
    (inst add result temp)

    (inst mov temp result)
    (inst shr temp 4)
    (inst and result #x0f0f0f0f)
    (inst and temp #x0f0f0f0f)
    (inst add result temp)

    (inst mov temp result)
    (inst shr temp 8)
    (inst and result #x00ff00ff)
    (inst and temp #x00ff00ff)
    (inst add result temp)

    (inst mov temp result)
    (inst shr temp 16)
    (inst and result #x0000ffff)
    (inst and temp #x0000ffff)
    (inst add result temp)))

923
924
925
926
927
928
929
930
931
932
933
(define-vop (sse3-unsigned-byte-32-count)
  (:translate logcount)
  (:note _N"inline (unsigned-byte 32) logcount")
  (:policy :fast-safe)
  (:args (arg :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:results (result :scs (unsigned-reg)))
  (:result-types positive-fixnum)
  (:guard (backend-featurep :sse3))
  (:generator 2
    (inst popcnt result arg)))
ram's avatar
ram committed
934
935
936
937
938
939
940
941
942
943
944
945
946


;;;; Binary conditional VOPs:

(define-vop (fast-conditional)
  (:conditional)
  (:info target not-p)
  (:effects)
  (:affected)
  (:policy :fast-safe))

(define-vop (fast-conditional/fixnum fast-conditional)
  (:args (x :scs (any-reg)
947
	    :load-if (not (and (sc-is x control-stack)
ram's avatar
ram committed
948
			       (sc-is y any-reg))))
949
	 (y :scs (any-reg control-stack)))
ram's avatar
ram committed
950
  (:arg-types tagged-num tagged-num)
951
  (:note _N"inline fixnum comparison"))
ram's avatar
ram committed
952
953

(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
954
  (:args (x :scs (any-reg control-stack)))
ram's avatar
ram committed
955
956
957
958
959
960
961
962
963
  (:arg-types tagged-num (:constant (signed-byte 30)))
  (:info target not-p y))

(define-vop (fast-conditional/signed fast-conditional)
  (:args (x :scs (signed-reg)
	    :load-if (not (and (sc-is x signed-stack)
			       (sc-is y signed-reg))))
	 (y :scs (signed-reg signed-stack)))
  (:arg-types signed-num signed-num)
964
  (:note _N"inline (signed-byte 32) comparison"))
ram's avatar
ram committed
965
966
967
968
969
970
971
972
973
974
975
976

(define-vop (fast-conditional-c/signed fast-conditional/signed)
  (:args (x :scs (signed-reg signed-stack)))
  (:arg-types signed-num (:constant (signed-byte 32)))
  (:info target not-p y))

(define-vop (fast-conditional/unsigned fast-conditional)
  (:args (x :scs (unsigned-reg)
	    :load-if (not (and (sc-is x unsigned-stack)
			       (sc-is y unsigned-reg))))
	 (y :scs (unsigned-reg unsigned-stack)))
  (:arg-types unsigned-num unsigned-num)
977
  (:note _N"inline (unsigned-byte 32) comparison"))
ram's avatar
ram committed
978
979
980
981
982
983
984
985
986
987
988

(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
  (:args (x :scs (unsigned-reg unsigned-stack)))
  (:arg-types unsigned-num (:constant (unsigned-byte 32)))
  (:info target not-p y))


(defmacro define-conditional-vop (tran cond unsigned not-cond not-unsigned)
  `(progn
     ,@(mapcar
	#'(lambda (suffix cost signed)
989
990
991
992
993
994
995
996
	    `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
					   tran suffix))
			  ,(intern
			    (format nil "~:@(FAST-CONDITIONAL~A~)"
				    suffix)))
	       (:translate ,tran)
	       (:generator ,cost
		 (inst cmp x
997
		       ,(if (eq suffix '-c/fixnum) '(fixnumize y) 'y))
998
999
1000
1001
		 (inst jmp (if not-p
			       ,(if signed not-cond not-unsigned)
			     ,(if signed cond unsigned))
		       target))))
ram's avatar
ram committed
1002
1003
1004
1005
1006
1007
1008
1009
	'(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
	'(4 3 6 5 6 5)
	'(t t t t nil nil))))

(define-conditional-vop < :l :b :ge :ae)

(define-conditional-vop > :g :a :le :be)

1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
(define-vop (fast-if-eql/signed fast-conditional/signed)
  (:translate eql)
  (:generator 6
    (inst cmp x y)
    (inst jmp (if not-p :ne :e) target)))

(define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
  (:translate eql)
  (:generator 5
    (cond ((and (sc-is x signed-reg) (zerop y))
	   (inst test x x))  ; Smaller instruction
	  (t
	   (inst cmp x y)))
    (inst jmp (if not-p :ne :e) target)))

(define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
  (:translate eql)
  (:generator 6
    (inst cmp x y)
    (inst jmp (if not-p :ne :e) target)))

(define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
  (:translate eql)
  (:generator 5
    (cond ((and (sc-is x unsigned-reg) (zerop y))
	   (inst test x x))  ; Smaller instruction
	  (t
	   (inst cmp x y)))
    (inst jmp (if not-p :ne :e) target)))
ram's avatar
ram committed
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051

;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
;;; known fixnum.

;;; These versions specify a fixnum restriction on their first arg.  We have
;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
;;; the first arg and a higher cost.  The reason for doing this is to prevent
;;; fixnum specific operations from being used on word integers, spuriously
;;; consing the argument.
;;;

(define-vop (fast-eql/fixnum fast-conditional)
  (:args (x :scs (any-reg)
1052
	    :load-if (not (and (sc-is x control-stack)
ram's avatar
ram committed
1053
			       (sc-is y any-reg))))
1054
	 (y :scs (any-reg control-stack)))
ram's avatar
ram committed
1055
  (:arg-types tagged-num tagged-num)
1056
  (:note _N"inline fixnum comparison")
ram's avatar
ram committed
1057
1058
1059
1060
1061
1062
  (:translate eql)
  (:generator 4
    (inst cmp x y)
    (inst jmp (if not-p :ne :e) target)))
;;;
(define-vop (generic-eql/fixnum fast-eql/fixnum)
1063
  (:args (x :scs (any-reg descriptor-reg)
1064
	    :load-if (not (and (sc-is x control-stack)
1065
			       (sc-is y any-reg))))
1066
	 (y :scs (any-reg control-stack)))
ram's avatar
ram committed
1067
1068
1069
1070
  (:arg-types * tagged-num)
  (:variant-cost 7))

(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
1071
  (:args (x :scs (any-reg control-stack)))
ram's avatar
ram committed
1072
1073
1074
1075
  (:arg-types tagged-num (:constant (signed-byte 30)))
  (:info target not-p y)
  (:translate eql)
  (:generator 2
1076
    (cond ((and (sc-is x any-reg descriptor-reg) (zerop y))
1077
1078
	   (inst test x x))  ; Smaller instruction
	  (t
1079
	   (inst cmp x (fixnumize y))))
ram's avatar
ram committed
1080
1081
1082
    (inst jmp (if not-p :ne :e) target)))
;;;
(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
1083
  (:args (x :scs (any-reg descriptor-reg control-stack)))
ram's avatar
ram committed
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
  (:arg-types * (:constant (signed-byte 30)))
  (:variant-cost 6))


;;;; 32-bit logical operations

(define-vop (merge-bits)
  (:translate merge-bits)
  (:args (shift :scs (signed-reg unsigned-reg) :target ecx)
	 (prev :scs (unsigned-reg) :target result)
	 (next :scs (unsigned-reg)))
  (:arg-types tagged-num unsigned-num unsigned-num)
1096
  (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 0)) ecx)
ram's avatar
ram committed
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
  (:results (result :scs (unsigned-reg) :from (:argument 1)))
  (:result-types unsigned-num)
  (:policy :fast-safe)
  (:generator 4
    (move ecx shift)
    (move result prev)
    (inst shrd result next :cl)))

(define-vop (32bit-logical)
  (:args (x :scs (unsigned-reg) :target r
	    :load-if (not (and (sc-is x unsigned-stack)
1108
			       (sc-is r unsigned-stack)
ram's avatar
ram committed
1109
1110
1111
1112
			       (location= x r))))
	 (y :scs (unsigned-reg)
	    :load-if (or (not (sc-is y unsigned-stack))
			 (and (sc-is x unsigned-stack)
1113
			      (sc-is y unsigned-stack)
ram's avatar
ram committed
1114
1115
1116
1117
			      (location= x r)))))
  (:arg-types unsigned-num unsigned-num)
  (:results (r :scs (unsigned-reg)  :from (:argument 0)
	       :load-if (not (and (sc-is x unsigned-stack)
1118
				  (sc-is r unsigned-stack)
ram's avatar
ram committed
1119
1120
1121
1122
1123
1124
1125
1126
				  (location= x r)))))
  (:result-types unsigned-num)
  (:policy :fast-safe))

(define-vop (32bit-logical-not)
  (:translate 32bit-logical-not)
  (:args (x :scs (unsigned-reg) :target r
	    :load-if (not (and (sc-is x unsigned-stack)
1127
			       (sc-is r unsigned-stack)
ram's avatar
ram committed
1128
1129
1130
1131
			       (location= x r)))))
  (:arg-types unsigned-num)
  (:results (r :scs (unsigned-reg)
	       :load-if (not (and (sc-is x unsigned-stack)
1132
				  (sc-is r unsigned-stack)
ram's avatar
ram committed
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
				  (location= x r)))))
  (:result-types unsigned-num)
  (:policy :fast-safe)
  (:generator 1
    (move r x)
    (inst not r)))

(define-vop (32bit-logical-and 32bit-logical)
  (:translate 32bit-logical-and)
  (:generator 1
    (move r x)
    (inst and r y)))

(def-source-transform 32bit-logical-nand (x y)
  `(32bit-logical-not (32bit-logical-and ,x ,y)))

(define-vop (32bit-logical-or 32bit-logical)
  (:translate 32bit-logical-or)
  (:generator 1
    (move r x)
    (inst or r y)))

(def-source-transform 32bit-logical-nor (x y)
  `(32bit-logical-not (32bit-logical-or ,x ,y)))

(define-vop (32bit-logical-xor 32bit-logical)
  (:translate 32bit-logical-xor)
  (:generator 1
    (move r x)
    (inst xor r y)))

(def-source-transform 32bit-logical-eqv (x y)
  `(32bit-logical-not (32bit-logical-xor ,x ,y)))

(def-source-transform 32bit-logical-orc1 (x y)
  `(32bit-logical-or (32bit-logical-not ,x) ,y))

(def-source-transform 32bit-logical-orc2 (x y)
  `(32bit-logical-or ,x (32bit-logical-not ,y)))

(def-source-transform 32bit-logical-andc1 (x y)
  `(32bit-logical-and (32bit-logical-not ,x) ,y))

(def-source-transform 32bit-logical-andc2 (x y)
  `(32bit-logical-and ,x (32bit-logical-not ,y)))

pw's avatar
pw committed
1179
;;; Only the lower 5 bits of the shift amount are significant.
ram's avatar
ram committed
1180
1181
1182
(define-vop (shift-towards-someplace)
  (:policy :fast-safe)
  (:args (num :scs (unsigned-reg) :target r)
pw's avatar
pw committed
1183
1184
	 (amount :scs (signed-reg) :target ecx))
  (:arg-types unsigned-num tagged-num)
1185
  (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
pw's avatar
pw committed
1186
  (:results (r :scs (unsigned-reg) :from (:argument 0)))
ram's avatar
ram committed
1187
1188
1189
1190
  (:result-types unsigned-num))

(define-vop (shift-towards-start shift-towards-someplace)
  (:translate shift-towards-start)
1191
  (:note _N"SHIFT-TOWARDS-START")
ram's avatar
ram committed
1192
1193
1194
1195
1196
1197
1198
  (:generator 1
    (move r num)
    (move ecx amount)
    (inst shr r :cl)))

(define-vop (shift-towards-end shift-towards-someplace)
  (:translate shift-towards-end)
1199
  (:note _N"SHIFT-TOWARDS-END")
ram's avatar
ram committed
1200
1201
1202
1203
1204
  (:generator 1
    (move r num)
    (move ecx amount)
    (inst shl r :cl)))

1205

ram's avatar
ram committed
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265

;;;; Bignum stuff.

(define-vop (bignum-length get-header-data)
  (:translate bignum::%bignum-length)
  (:policy :fast-safe))

(define-vop (bignum-set-length set-header-data)
  (:translate bignum::%bignum-set-length)
  (:policy :fast-safe))

(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type
  (unsigned-reg) unsigned-num bignum::%bignum-ref)

(define-full-setter bignum-set * bignum-digits-offset other-pointer-type
  (unsigned-reg) unsigned-num bignum::%bignum-set)

(define-vop (digit-0-or-plus)
  (:translate bignum::%digit-0-or-plusp)
  (:policy :fast-safe)
  (:args (digit :scs (unsigned-reg)))
  (:arg-types unsigned-num)
  (:conditional)
  (:info target not-p)
  (:generator 3
    (inst or digit digit)
    (inst jmp (if not-p :s :ns) target)))


;;; For add and sub with carry the sc of carry argument is any-reg so
;;; the it may be passed as a fixnum or word and thus may be 0, 1, or
;;; 4. This is easy to deal with and may save a fixnum-word
;;; conversion.
;;;
(define-vop (add-w/carry)
  (:translate bignum::%add-with-carry)
  (:policy :fast-safe)
  (:args (a :scs (unsigned-reg) :target result)
	 (b :scs (unsigned-reg unsigned-stack) :to :eval)
	 (c :scs (any-reg) :target temp))
  (:arg-types unsigned-num unsigned-num positive-fixnum)
  (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
  (:results (result :scs (unsigned-reg) :from (:argument 0))
	    (carry :scs (unsigned-reg)))
  (:result-types unsigned-num positive-fixnum)
  (:generator 4
    (move result a)
    (move temp c)
    (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
    (inst adc result b)
    (inst mov carry 0)
    (inst adc carry carry)))

;;; Note: the borrow is the oppostite of the x86 convention - 1 for no
;;; borrow and 0 for a borrow.
(define-vop (sub-w/borrow)
  (:translate bignum::%subtract-with-borrow)
  (:policy :fast-safe)
  (:args (a :scs (unsigned-reg) :to :eval :target result)
	 (b :scs (unsigned-reg unsigned-stack) :to :result)
1266
	 (c :scs (any-reg control-stack)))
ram's avatar
ram committed
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
  (:arg-types unsigned-num unsigned-num positive-fixnum)
  (:results (result :scs (unsigned-reg) :from :eval)
	    (borrow :scs (unsigned-reg)))
  (:result-types unsigned-num positive-fixnum)
  (:generator 5
    (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
    (move result a)
    (inst sbb result b)
    (inst mov borrow 0)
    (inst adc borrow borrow)
    (inst xor borrow 1)))


(define-vop (bignum-mult-and-add-3-arg)
  (:translate bignum::%multiply-and-add)
  (:policy :fast-safe)
1283
  (:args (x :scs (unsigned-reg) :target eax)
ram's avatar
ram committed
1284
1285
1286
1287
1288
1289
1290
	 (y :scs (unsigned-reg unsigned-stack))
	 (carry-in :scs (unsigned-reg unsigned-stack)))
  (:arg-types unsigned-num unsigned-num unsigned-num)
  (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
		   :to (:result 1) :target lo) eax)
  (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
		   :to (:result 0) :target hi) edx)
1291
1292
  (:results (hi :scs (unsigned-reg))
	    (lo :scs (unsigned-reg)))
ram's avatar
ram committed
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
  (:result-types unsigned-num unsigned-num)
  (:generator 20
    (move eax x)
    (inst mul eax y)
    (inst add eax carry-in)
    (inst adc edx 0)
    (move hi edx)
    (move lo eax)))

(define-vop (bignum-mult-and-add-4-arg)
  (:translate bignum::%multiply-and-add)
  (:policy :fast-safe)
1305
  (:args (x :scs (unsigned-reg) :target eax)
ram's avatar
ram committed
1306
1307
1308
1309
1310
1311
1312
1313
	 (y :scs (unsigned-reg unsigned-stack))
	 (prev :scs (unsigned-reg unsigned-stack))
	 (carry-in :scs (unsigned-reg unsigned-stack)))
  (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
  (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
		   :to (:result 1) :target lo) eax)
  (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
		   :to (:result 0) :target hi) edx)
dtc's avatar