9004b6daf2ac410cafdb2eac7e434b81f94588dd
[sbcl.git] / src / compiler / ppc / arith.lisp
1 ;;;; the VM definition arithmetic VOPs for the PPC
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)))
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)))
30   (:results (res :scs (signed-reg)))
31   (:note "inline (signed-byte 32) arithmetic")
32   (:arg-types signed-num)
33   (:result-types signed-num))
34
35 (define-vop (fast-negate/fixnum fixnum-unop)
36   (:translate %negate)
37   (:generator 1
38     (inst neg res x)))
39
40 (define-vop (fast-negate/signed signed-unop)
41   (:translate %negate)
42   (:generator 2
43     (inst neg res x)))
44
45 (define-vop (fast-lognot/fixnum fixnum-unop)
46   (:translate lognot)
47   (:generator 2
48     (inst xori res x (fixnumize -1))))
49
50 (define-vop (fast-lognot/signed signed-unop)
51   (:translate lognot)
52   (:generator 1
53     (inst not res x)))
54 \f
55 ;;;; Binary fixnum operations.
56
57 ;;; Assume that any constant operand is the second arg...
58
59 (define-vop (fast-fixnum-binop fast-safe-arith-op)
60   (:args (x :target r :scs (any-reg zero))
61          (y :target r :scs (any-reg zero)))
62   (:arg-types tagged-num tagged-num)
63   (:results (r :scs (any-reg)))
64   (:result-types tagged-num)
65   (:note "inline fixnum arithmetic"))
66
67 (define-vop (fast-unsigned-binop fast-safe-arith-op)
68   (:args (x :target r :scs (unsigned-reg zero))
69          (y :target r :scs (unsigned-reg zero)))
70   (:arg-types unsigned-num unsigned-num)
71   (:results (r :scs (unsigned-reg)))
72   (:result-types unsigned-num)
73   (:note "inline (unsigned-byte 32) arithmetic"))
74
75 (define-vop (fast-signed-binop fast-safe-arith-op)
76   (:args (x :target r :scs (signed-reg zero))
77          (y :target r :scs (signed-reg zero)))
78   (:arg-types signed-num signed-num)
79   (:results (r :scs (signed-reg)))
80   (:result-types signed-num)
81   (:note "inline (signed-byte 32) arithmetic"))
82
83 (define-vop (fast-fixnum-binop-c fast-safe-arith-op)
84   (:args (x :target r :scs (any-reg zero)))
85   (:info y)
86   (:arg-types tagged-num
87               (:constant (and (signed-byte 14) (not (integer 0 0)))))
88   (:results (r :scs (any-reg)))
89   (:result-types tagged-num)
90   (:note "inline fixnum arithmetic"))
91
92 (define-vop (fast-fixnum-logop-c fast-safe-arith-op)
93   (:args (x :target r :scs (any-reg zero)))
94   (:info y)
95   (:arg-types tagged-num
96               (:constant (and (unsigned-byte 14) (not (integer 0 0)))))
97   (:results (r :scs (any-reg)))
98   (:result-types tagged-num)
99   (:note "inline fixnum logical op"))
100
101 (define-vop (fast-unsigned-binop-c fast-safe-arith-op)
102   (:args (x :target r :scs (unsigned-reg zero)))
103   (:info y)
104   (:arg-types unsigned-num
105               (:constant (and (signed-byte 16) (not (integer 0 0)))))
106   (:results (r :scs (unsigned-reg)))
107   (:result-types unsigned-num)
108   (:note "inline (unsigned-byte 32) arithmetic"))
109
110 (define-vop (fast-unsigned-logop-c fast-safe-arith-op)
111   (:args (x :target r :scs (unsigned-reg zero)))
112   (:info y)
113   (:arg-types unsigned-num
114               (:constant (and (unsigned-byte 16) (not (integer 0 0)))))
115   (:results (r :scs (unsigned-reg)))
116   (:result-types unsigned-num)
117   (:note "inline (unsigned-byte 32) logical op"))
118
119 (define-vop (fast-signed-binop-c fast-safe-arith-op)
120   (:args (x :target r :scs (signed-reg zero)))
121   (:info y)
122   (:arg-types signed-num
123               (:constant (and (signed-byte 16) (not (integer 0 0)))))
124   (:results (r :scs (signed-reg)))
125   (:result-types signed-num)
126   (:note "inline (signed-byte 32) arithmetic"))
127
128 (define-vop (fast-signed-logop-c fast-safe-arith-op)
129   (:args (x :target r :scs (signed-reg zero)))
130   (:info y)
131   (:arg-types signed-num
132               (:constant (and (unsigned-byte 16) (not (integer 0 0)))))
133   (:results (r :scs (signed-reg)))
134   (:result-types signed-num)
135   (:note "inline (signed-byte 32) arithmetic"))
136
137
138 (eval-when (:compile-toplevel :load-toplevel :execute)
139
140 (defmacro define-var-binop (translate untagged-penalty op 
141                             &optional arg-swap restore-fixnum-mask)
142   `(progn
143      (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
144                   fast-fixnum-binop)
145        ,@(when restore-fixnum-mask
146            `((:temporary (:sc non-descriptor-reg) temp)))
147        (:translate ,translate)
148        (:generator 2
149          ,(if arg-swap
150              `(inst ,op ,(if restore-fixnum-mask 'temp 'r) y x)
151              `(inst ,op ,(if restore-fixnum-mask 'temp 'r) x y))
152          ;; FIXME: remind me what convention we used for 64bitizing
153          ;; stuff?  -- CSR, 2003-08-27
154          ,@(when restore-fixnum-mask
155              `((inst clrrwi r temp (1- n-lowtag-bits))))))
156      (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
157                   fast-signed-binop)
158        (:translate ,translate)
159        (:generator ,(1+ untagged-penalty)
160          ,(if arg-swap
161              `(inst ,op r y x)
162              `(inst ,op r x y))))
163      (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
164                   fast-unsigned-binop)
165        (:translate ,translate)
166        (:generator ,(1+ untagged-penalty)
167          ,(if arg-swap
168              `(inst ,op r y x)
169              `(inst ,op r x y))))))
170
171
172 (defmacro define-const-binop (translate untagged-penalty op)
173   `(progn
174      
175      (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
176                   fast-fixnum-binop-c)
177        (:translate ,translate)
178        (:generator 1
179          (inst ,op r x (fixnumize y))))
180      (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
181                   fast-signed-binop-c)
182        (:translate ,translate)
183        (:generator ,untagged-penalty
184          (inst ,op r x y)))
185      (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
186                   fast-unsigned-binop-c)
187        (:translate ,translate)
188        (:generator ,untagged-penalty
189          (inst ,op r x y)))))
190
191 (defmacro define-const-logop (translate untagged-penalty op)
192   `(progn
193      
194      (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
195                   fast-fixnum-logop-c)
196        (:translate ,translate)
197        (:generator 1
198          (inst ,op r x (fixnumize y))))
199      (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
200                   fast-signed-logop-c)
201        (:translate ,translate)
202        (:generator ,untagged-penalty
203          (inst ,op r x y)))
204      (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
205                   fast-unsigned-logop-c)
206        (:translate ,translate)
207        (:generator ,untagged-penalty
208          (inst ,op r x y)))))
209
210 ); eval-when
211
212 (define-var-binop + 4 add)
213 (define-var-binop - 4 sub)
214 (define-var-binop logand 2 and)
215 (define-var-binop logandc1 2 andc t)
216 (define-var-binop logandc2 2 andc)
217 (define-var-binop logior 2 or)
218 (define-var-binop logorc1 2 orc t t)
219 (define-var-binop logorc2 2 orc nil t)
220 (define-var-binop logxor 2 xor)
221 (define-var-binop logeqv 2 eqv nil t)
222 (define-var-binop lognand 2 nand nil t)
223 (define-var-binop lognor 2 nor nil t)
224
225 (define-const-binop + 4 addi)
226 (define-const-binop - 4 subi)
227 (define-const-logop logand 2 andi.)
228 (define-const-logop logior 2 ori)
229 (define-const-logop logxor 2 xori)
230
231
232 ;;; Special case fixnum + and - that trap on overflow.  Useful when we
233 ;;; don't know that the output type is a fixnum.
234 ;;;
235 (define-vop (+/fixnum fast-+/fixnum=>fixnum)
236   (:policy :safe)
237   (:results (r :scs (any-reg descriptor-reg)))
238   (:result-types tagged-num)
239   (:note "safe inline fixnum arithmetic")
240   (:generator 4
241     (let* ((no-overflow (gen-label)))
242       (inst mtxer zero-tn)
243       (inst addo. r x y)
244       (inst bns no-overflow)
245       (inst unimp (logior (ash (reg-tn-encoding r) 5)
246                           fixnum-additive-overflow-trap))
247       (emit-label no-overflow))))
248
249
250 (define-vop (-/fixnum fast--/fixnum=>fixnum)
251   (:policy :safe)
252   (:results (r :scs (any-reg descriptor-reg)))
253   (:result-types tagged-num)
254   (:note "safe inline fixnum arithmetic")
255   (:generator 4
256     (let* ((no-overflow (gen-label)))
257       (inst mtxer zero-tn)
258       (inst subo. r x y)
259       (inst bns no-overflow)
260       (inst unimp (logior (ash (reg-tn-encoding r) 5)
261                           fixnum-additive-overflow-trap))
262       (emit-label no-overflow))))
263
264 (define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
265   (:temporary (:scs (non-descriptor-reg)) temp)
266   (:translate *)
267   (:generator 2
268     (inst srawi temp y 2)
269     (inst mullw r x temp)))
270
271 (define-vop (fast-*-c/fixnum=>fixnum fast-fixnum-binop-c)
272   (:translate *)
273   (:arg-types tagged-num 
274               (:constant (and (signed-byte 16) (not (integer 0 0)))))
275   (:generator 1
276     (inst mulli r x y)))
277
278 (define-vop (fast-*-bigc/fixnum=>fixnum fast-fixnum-binop-c)
279   (:translate *)
280   (:arg-types tagged-num
281               (:constant (and fixnum (not (signed-byte 16)))))
282   (:temporary (:scs (non-descriptor-reg)) temp)
283   (:generator 1
284     (inst lr temp y)
285     (inst mullw r x temp)))
286
287 (define-vop (fast-*/signed=>signed fast-signed-binop)
288   (:translate *)
289   (:generator 4
290     (inst mullw r x y)))
291
292 (define-vop (fast-*-c/signed=>signed fast-signed-binop-c)
293   (:translate *)
294   (:generator 3
295     (inst mulli r x y)))
296
297 (define-vop (fast-*/unsigned=>unsigned fast-unsigned-binop)
298   (:translate *)
299   (:generator 4
300     (inst mullw r x y)))
301
302 (define-vop (fast-*-c/unsigned=>unsigned fast-unsigned-binop-c)
303   (:translate *)
304   (:generator 3
305     (inst mulli r x y)))
306 \f
307 ;;; Shifting
308
309 (macrolet ((def (name sc-type type result-type cost)
310              `(define-vop (,name)
311                 (:note "inline ASH")
312                 (:translate ash)
313                 (:args (number :scs (,sc-type))
314                        (amount :scs (signed-reg unsigned-reg immediate)))
315                 (:arg-types ,type positive-fixnum)
316                 (:results (result :scs (,result-type)))
317                 (:result-types ,type)
318                 (:policy :fast-safe)
319                 (:generator ,cost
320                    (sc-case amount
321                      ((signed-reg unsigned-reg) 
322                       (inst slw result number amount))
323                      (immediate
324                       (let ((amount (tn-value amount)))
325                         (aver (> amount 0))
326                         (inst slwi result number amount))))))))
327   ;; FIXME: There's the opportunity for a sneaky optimization here, I
328   ;; think: a FAST-ASH-LEFT-C/FIXNUM=>SIGNED vop.  -- CSR, 2003-09-03
329   (def fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2)
330   (def fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3)
331   (def fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3))
332
333 (define-vop (fast-ash/unsigned=>unsigned)
334   (:note "inline ASH")
335   (:args (number :scs (unsigned-reg) :to :save)
336          (amount :scs (signed-reg)))
337   (:arg-types (:or unsigned-num) signed-num)
338   (:results (result :scs (unsigned-reg)))
339   (:result-types unsigned-num)
340   (:translate ash)
341   (:policy :fast-safe)
342   (:temporary (:sc non-descriptor-reg) ndesc)
343   (:generator 5
344     (let ((positive (gen-label))
345           (done (gen-label)))
346       (inst cmpwi amount 0)
347       (inst neg ndesc amount)
348       (inst bge positive)
349       (inst cmpwi ndesc 31)
350       (inst srw result number ndesc)
351       (inst ble done)
352       (move result zero-tn)
353       (inst b done)
354       
355       (emit-label positive)
356       ;; The result-type assures us that this shift will not overflow.
357       (inst slw result number amount)
358       
359       (emit-label done))))
360
361 (define-vop (fast-ash-c/unsigned=>unsigned)
362   (:note "inline constant ASH")
363   (:args (number :scs (unsigned-reg)))
364   (:info amount)
365   (:arg-types unsigned-num (:constant integer))
366   (:results (result :scs (unsigned-reg)))
367   (:result-types unsigned-num)
368   (:translate ash)
369   (:policy :fast-safe)
370   (:generator 4
371     (cond
372       ((and (minusp amount) (< amount -31)) (move result zero-tn))
373       ((minusp amount) (inst srwi result number (- amount)))
374       ;; possible because this is used in the modular version too
375       ((> amount 31) (move result zero-tn))
376       (t (inst slwi result number amount)))))
377
378 (define-vop (fast-ash/signed=>signed)
379   (:note "inline ASH")
380   (:args (number :scs (signed-reg) :to :save)
381          (amount :scs (signed-reg immediate)))
382   (:arg-types (:or signed-num) signed-num)
383   (:results (result :scs (signed-reg)))
384   (:result-types (:or signed-num))
385   (:translate ash)
386   (:policy :fast-safe)
387   (:temporary (:sc non-descriptor-reg) ndesc)
388   (:generator 3
389     (sc-case amount
390       (signed-reg
391        (let ((positive (gen-label))
392              (done (gen-label)))
393          (inst cmpwi amount 0)
394          (inst neg ndesc amount)
395          (inst bge positive)
396          (inst cmpwi ndesc 31)
397          (inst sraw result number ndesc)
398          (inst ble done)
399          (inst srawi result number 31)
400          (inst b done)
401
402          (emit-label positive)
403          ;; The result-type assures us that this shift will not overflow.
404          (inst slw result number amount)
405
406          (emit-label done)))
407
408       (immediate
409        (let ((amount (tn-value amount)))
410          (if (minusp amount)
411              (let ((amount (min 31 (- amount))))
412                (inst srawi result number amount))
413              (inst slwi result number amount)))))))
414
415
416
417 (define-vop (signed-byte-32-len)
418   (:translate integer-length)
419   (:note "inline (signed-byte 32) integer-length")
420   (:policy :fast-safe)
421   (:args (arg :scs (signed-reg)))
422   (:arg-types signed-num)
423   (:results (res :scs (any-reg)))
424   (:result-types positive-fixnum)
425   (:temporary (:scs (non-descriptor-reg) :to (:argument 0)) shift)
426   (:generator 6
427     ; (integer-length arg) = (- 32 (cntlz (if (>= arg 0) arg (lognot arg))))
428     (let ((nonneg (gen-label)))
429       (inst cntlzw. shift arg)
430       (inst bne nonneg)
431       (inst not shift arg)
432       (inst cntlzw shift shift)
433       (emit-label nonneg)
434       (inst slwi shift shift 2)
435       (inst subfic res  shift (fixnumize 32)))))
436
437 (define-vop (unsigned-byte-32-count)
438   (:translate logcount)
439   (:note "inline (unsigned-byte 32) logcount")
440   (:policy :fast-safe)
441   (:args (arg :scs (unsigned-reg) :target shift))
442   (:arg-types unsigned-num)
443   (:results (res :scs (any-reg)))
444   (:result-types positive-fixnum)
445   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift temp)
446   (:generator 30
447     (let ((loop (gen-label))
448           (done (gen-label)))
449       (inst add. shift zero-tn arg)
450       (move res zero-tn)
451       (inst beq done)
452
453       (emit-label loop)
454       (inst subi temp shift 1)
455       (inst and. shift shift temp)
456       (inst addi res res (fixnumize 1))
457       (inst bne loop)
458
459       (emit-label done))))
460
461 \f
462 ;;;; Modular functions:
463 (define-modular-fun lognot-mod32 (x) lognot 32)
464 (define-vop (lognot-mod32/unsigned=>unsigned)
465   (:translate lognot-mod32)
466   (:args (x :scs (unsigned-reg)))
467   (:arg-types unsigned-num)
468   (:results (res :scs (unsigned-reg)))
469   (:result-types unsigned-num)
470   (:policy :fast-safe)
471   (:generator 1
472     (inst not res x)))
473
474 (define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
475              fast-ash-c/unsigned=>unsigned)
476   (:translate ash-left-mod32))
477
478 (macrolet 
479     ((define-modular-backend (fun &optional constantp)
480        (let ((mfun-name (symbolicate fun '-mod32))
481              (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
482              (modcvop (symbolicate 'fast- fun 'mod32-c/unsigned=>unsigned))
483              (vop (symbolicate 'fast- fun '/unsigned=>unsigned))
484              (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
485          `(progn
486             (define-modular-fun ,mfun-name (x y) ,fun 32)
487             (define-vop (,modvop ,vop)
488               (:translate ,mfun-name))
489             ,@(when constantp
490                 `((define-vop (,modcvop ,cvop)
491                     (:translate ,mfun-name))))))))
492   (define-modular-backend + t)
493   (define-modular-backend - t)
494   (define-modular-backend * t)
495   (define-modular-backend logxor t)
496   (define-modular-backend logeqv)
497   (define-modular-backend lognand)
498   (define-modular-backend lognor)
499   (define-modular-backend logandc1)
500   (define-modular-backend logandc2)
501   (define-modular-backend logorc1)
502   (define-modular-backend logorc2))
503 \f
504 ;;;; Binary conditional VOPs:
505
506 (define-vop (fast-conditional)
507   (:conditional)
508   (:info target not-p)
509   (:effects)
510   (:affected)
511   (:policy :fast-safe))
512
513 (define-vop (fast-conditional/fixnum fast-conditional)
514   (:args (x :scs (any-reg zero))
515          (y :scs (any-reg zero)))
516   (:arg-types tagged-num tagged-num)
517   (:note "inline fixnum comparison"))
518
519 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
520   (:args (x :scs (any-reg zero)))
521   (:arg-types tagged-num (:constant (signed-byte 14)))
522   (:info target not-p y))
523
524 (define-vop (fast-conditional/signed fast-conditional)
525   (:args (x :scs (signed-reg zero))
526          (y :scs (signed-reg zero)))
527   (:arg-types signed-num signed-num)
528   (:note "inline (signed-byte 32) comparison"))
529
530 (define-vop (fast-conditional-c/signed fast-conditional/signed)
531   (:args (x :scs (signed-reg zero)))
532   (:arg-types signed-num (:constant (signed-byte 16)))
533   (:info target not-p y))
534
535 (define-vop (fast-conditional/unsigned fast-conditional)
536   (:args (x :scs (unsigned-reg zero))
537          (y :scs (unsigned-reg zero)))
538   (:arg-types unsigned-num unsigned-num)
539   (:note "inline (unsigned-byte 32) comparison"))
540
541 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
542   (:args (x :scs (unsigned-reg zero)))
543   (:arg-types unsigned-num (:constant (unsigned-byte 16)))
544   (:info target not-p y))
545
546
547 (define-vop (fast-if-</fixnum fast-conditional/fixnum)
548   (:translate <)
549   (:generator 4
550     (inst cmpw x y)
551     (inst b? (if not-p :ge :lt) target)))
552
553 (define-vop (fast-if-<-c/fixnum fast-conditional-c/fixnum)
554   (:translate <)
555   (:generator 3
556     (inst cmpwi x (fixnumize y))
557     (inst b? (if not-p :ge :lt) target)))
558
559 (define-vop (fast-if-</signed fast-conditional/signed)
560   (:translate <)
561   (:generator 6
562     (inst cmpw x y)
563     (inst b? (if not-p :ge :lt) target)))
564
565 (define-vop (fast-if-<-c/signed fast-conditional-c/signed)
566   (:translate <)
567   (:generator 5
568     (inst cmpwi x y)
569     (inst b? (if not-p :ge :lt) target)))
570
571 (define-vop (fast-if-</unsigned fast-conditional/unsigned)
572   (:translate <)
573   (:generator 6
574     (inst cmplw x y)
575     (inst b? (if not-p :ge :lt) target)))
576
577 (define-vop (fast-if-<-c/unsigned fast-conditional-c/unsigned)
578   (:translate <)
579   (:generator 5
580     (inst cmplwi x y)
581     (inst b? (if not-p :ge :lt) target)))
582
583 (define-vop (fast-if->/fixnum fast-conditional/fixnum)
584   (:translate >)
585   (:generator 4
586     (inst cmpw x y)
587     (inst b? (if not-p :le :gt) target)))
588
589 (define-vop (fast-if->-c/fixnum fast-conditional-c/fixnum)
590   (:translate >)
591   (:generator 3
592     (inst cmpwi x (fixnumize y))
593     (inst b? (if not-p :le :gt) target)))
594
595 (define-vop (fast-if->/signed fast-conditional/signed)
596   (:translate >)
597   (:generator 6
598     (inst cmpw x y)
599     (inst b? (if not-p :le :gt) target)))
600
601 (define-vop (fast-if->-c/signed fast-conditional-c/signed)
602   (:translate >)
603   (:generator 5
604     (inst cmpwi x y)
605     (inst b? (if not-p :le :gt) target)))
606
607 (define-vop (fast-if->/unsigned fast-conditional/unsigned)
608   (:translate >)
609   (:generator 6
610     (inst cmplw x y)
611     (inst b? (if not-p :le :gt) target)))
612
613 (define-vop (fast-if->-c/unsigned fast-conditional-c/unsigned)
614   (:translate >)
615   (:generator 5
616     (inst cmplwi x y)
617     (inst b? (if not-p :le :gt) target)))
618
619 (define-vop (fast-if-eql/signed fast-conditional/signed)
620   (:translate eql)
621   (:generator 6
622     (inst cmpw x y)
623     (inst b? (if not-p :ne :eq) target)))
624
625 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
626   (:translate eql)
627   (:generator 5
628     (inst cmpwi x y)
629     (inst b? (if not-p :ne :eq) target)))
630
631 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
632   (:translate eql)
633   (:generator 6
634     (inst cmplw x y)
635     (inst b? (if not-p :ne :eq) target)))
636
637 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
638   (:translate eql)
639   (:generator 5
640     (inst cmplwi x y)
641     (inst b? (if not-p :ne :eq) target)))
642
643
644 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
645 ;;; known fixnum.
646
647 ;;; These versions specify a fixnum restriction on their first arg.  We have
648 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
649 ;;; the first arg and a higher cost.  The reason for doing this is to prevent
650 ;;; fixnum specific operations from being used on word integers, spuriously
651 ;;; consing the argument.
652 ;;;
653
654 (define-vop (fast-eql/fixnum fast-conditional)
655   (:args (x :scs (any-reg descriptor-reg zero))
656          (y :scs (any-reg zero)))
657   (:arg-types tagged-num tagged-num)
658   (:note "inline fixnum comparison")
659   (:translate eql)
660   (:generator 4
661     (inst cmpw x y)
662     (inst b? (if not-p :ne :eq) target)))
663 ;;;
664 (define-vop (generic-eql/fixnum fast-eql/fixnum)
665   (:arg-types * tagged-num)
666   (:variant-cost 7))
667
668 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
669   (:args (x :scs (any-reg descriptor-reg zero)))
670   (:arg-types tagged-num (:constant (signed-byte 14)))
671   (:info target not-p y)
672   (:translate eql)
673   (:generator 2
674     (inst cmpwi x (fixnumize y))
675     (inst b? (if not-p :ne :eq) target)))
676 ;;;
677 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
678   (:arg-types * (:constant (signed-byte 11)))
679   (:variant-cost 6))
680
681 \f
682 ;;;; 32-bit logical operations
683
684 (define-vop (merge-bits)
685   (:translate merge-bits)
686   (:args (shift :scs (signed-reg unsigned-reg))
687          (prev :scs (unsigned-reg))
688          (next :scs (unsigned-reg)))
689   (:arg-types tagged-num unsigned-num unsigned-num)
690   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
691   (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
692   (:results (result :scs (unsigned-reg)))
693   (:result-types unsigned-num)
694   (:policy :fast-safe)
695   (:generator 4
696     (let ((done (gen-label)))
697       (inst cmpwi shift 0)
698       (inst beq done)
699       (inst srw res next shift)
700       (inst sub temp zero-tn shift)
701       (inst slw temp prev temp)
702       (inst or res res temp)
703       (emit-label done)
704       (move result res))))
705
706 (define-source-transform 32bit-logical-not (x)
707   `(logand (lognot (the (unsigned-byte 32) ,x)) #.(1- (ash 1 32))))
708
709 (deftransform 32bit-logical-and ((x y))
710   '(logand x y))
711
712 (deftransform 32bit-logical-nand ((x y))
713   '(logand (lognand x y) #.(1- (ash 1 32))))
714
715 (deftransform 32bit-logical-or ((x y))
716   '(logior x y))
717
718 (deftransform 32bit-logical-nor ((x y))
719   '(logand (lognor x y) #.(1- (ash 1 32))))
720
721 (deftransform 32bit-logical-xor ((x y))
722   '(logxor x y))
723
724 (deftransform 32bit-logical-eqv ((x y))
725   '(logand (logeqv x y) #.(1- (ash 1 32))))
726
727 (deftransform 32bit-logical-orc1 ((x y))
728   '(logand (logorc1 x y) #.(1- (ash 1 32))))
729
730 (deftransform 32bit-logical-orc2 ((x y))
731   '(logand (logorc2 x y) #.(1- (ash 1 32))))
732
733 (deftransform 32bit-logical-andc1 ((x y))
734   '(logand (logandc1 x y) #.(1- (ash 1 32))))
735
736 (deftransform 32bit-logical-andc2 ((x y))
737   '(logand (logandc2 x y) #.(1- (ash 1 32))))
738
739 (define-vop (shift-towards-someplace)
740   (:policy :fast-safe)
741   (:args (num :scs (unsigned-reg))
742          (amount :scs (signed-reg)))
743   (:arg-types unsigned-num tagged-num)
744   (:results (r :scs (unsigned-reg)))
745   (:result-types unsigned-num))
746
747 (define-vop (shift-towards-start shift-towards-someplace)
748   (:translate shift-towards-start)
749   (:note "shift-towards-start")
750   (:generator 1
751     (inst rlwinm amount amount 0 27 31)
752     (inst slw r num amount)))
753
754 (define-vop (shift-towards-end shift-towards-someplace)
755   (:translate shift-towards-end)
756   (:note "shift-towards-end")
757   (:generator 1
758     (inst rlwinm amount amount 0 27 31)
759     (inst srw r num amount)))
760 \f
761 ;;;; Bignum stuff.
762
763 (define-vop (bignum-length get-header-data)
764   (:translate sb!bignum:%bignum-length)
765   (:policy :fast-safe))
766
767 (define-vop (bignum-set-length set-header-data)
768   (:translate sb!bignum:%bignum-set-length)
769   (:policy :fast-safe))
770
771 (define-vop (bignum-ref word-index-ref)
772   (:variant bignum-digits-offset other-pointer-lowtag)
773   (:translate sb!bignum:%bignum-ref)
774   (:results (value :scs (unsigned-reg)))
775   (:result-types unsigned-num))
776
777 (define-vop (bignum-set word-index-set)
778   (:variant bignum-digits-offset other-pointer-lowtag)
779   (:translate sb!bignum:%bignum-set)
780   (:args (object :scs (descriptor-reg))
781          (index :scs (any-reg immediate zero))
782          (value :scs (unsigned-reg)))
783   (:arg-types t positive-fixnum unsigned-num)
784   (:results (result :scs (unsigned-reg)))
785   (:result-types unsigned-num))
786
787 (define-vop (digit-0-or-plus)
788   (:translate sb!bignum:%digit-0-or-plusp)
789   (:policy :fast-safe)
790   (:args (digit :scs (unsigned-reg)))
791   (:arg-types unsigned-num)
792   (:results (result :scs (descriptor-reg)))
793   (:generator 3
794     (let ((done (gen-label)))
795       (inst cmpwi digit 0)
796       (move result null-tn)
797       (inst blt done)
798       (load-symbol result t)
799       (emit-label done))))
800
801 (define-vop (add-w/carry)
802   (:translate sb!bignum:%add-with-carry)
803   (:policy :fast-safe)
804   (:args (a :scs (unsigned-reg))
805          (b :scs (unsigned-reg))
806          (c :scs (any-reg)))
807   (:arg-types unsigned-num unsigned-num positive-fixnum)
808   (:temporary (:scs (unsigned-reg)) temp)
809   (:results (result :scs (unsigned-reg))
810             (carry :scs (unsigned-reg)))
811   (:result-types unsigned-num positive-fixnum)
812   (:generator 3
813     (inst addic temp c -1)
814     (inst adde result a b)
815     (inst addze carry zero-tn)))
816
817 (define-vop (sub-w/borrow)
818   (:translate sb!bignum:%subtract-with-borrow)
819   (:policy :fast-safe)
820   (:args (a :scs (unsigned-reg))
821          (b :scs (unsigned-reg))
822          (c :scs (any-reg)))
823   (:arg-types unsigned-num unsigned-num positive-fixnum)
824   (:temporary (:scs (unsigned-reg)) temp)
825   (:results (result :scs (unsigned-reg))
826             (borrow :scs (unsigned-reg)))
827   (:result-types unsigned-num positive-fixnum)
828   (:generator 4
829     (inst addic temp c -1)
830     (inst sube result a b)
831     (inst addze borrow zero-tn)))
832
833 (define-vop (bignum-mult-and-add-3-arg)
834   (:translate sb!bignum:%multiply-and-add)
835   (:policy :fast-safe)
836   (:args (x :scs (unsigned-reg))
837          (y :scs (unsigned-reg))
838          (carry-in :scs (unsigned-reg) :to (:eval 1)))
839   (:arg-types unsigned-num unsigned-num unsigned-num)
840   (:temporary (:scs (unsigned-reg) :to (:result 0) :target hi) hi-temp)
841   (:temporary (:scs (unsigned-reg) :from (:eval 0) :to (:result 1)
842                     :target lo) lo-temp)
843   (:results (hi :scs (unsigned-reg))
844             (lo :scs (unsigned-reg)))
845   (:result-types unsigned-num unsigned-num)
846   (:generator 40
847     (inst mulhwu hi-temp x y)
848     (inst mullw lo-temp x y)
849     (inst addc lo lo-temp carry-in)
850     (inst addze hi hi-temp)))
851
852 (define-vop (bignum-mult-and-add-4-arg)
853   (:translate sb!bignum:%multiply-and-add)
854   (:policy :fast-safe)
855   (:args (x :scs (unsigned-reg))
856          (y :scs (unsigned-reg))
857          (prev :scs (unsigned-reg) :to (:eval 1))
858          (carry-in :scs (unsigned-reg) :to (:eval 1)))
859   (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
860   (:temporary (:scs (unsigned-reg) :to (:result 0) :target hi) hi-temp)
861   (:temporary (:scs (unsigned-reg) :from (:eval 0) :to (:result 1)
862                     :target lo) lo-temp)
863   (:results (hi :scs (unsigned-reg))
864             (lo :scs (unsigned-reg)))
865   (:result-types unsigned-num unsigned-num)
866   (:generator 40
867     (inst mulhwu hi-temp x y)
868     (inst mullw lo-temp x y)
869     (inst addc lo-temp lo-temp carry-in)
870     (inst addze hi-temp hi-temp)
871     (inst addc lo lo-temp prev)
872     (inst addze hi hi-temp)))
873
874 (define-vop (bignum-mult)
875   (:translate sb!bignum:%multiply)
876   (:policy :fast-safe)
877   (:args (x :scs (unsigned-reg) :to (:eval 1))
878          (y :scs (unsigned-reg) :to (:eval 1)))
879   (:arg-types unsigned-num unsigned-num)
880   (:results (hi :scs (unsigned-reg) :from (:eval 1))
881             (lo :scs (unsigned-reg) :from (:eval 0)))
882   (:result-types unsigned-num unsigned-num)
883   (:generator 40
884     (inst mullw lo x y)
885     (inst mulhwu hi x y)))
886
887 (define-vop (bignum-lognot lognot-mod32/unsigned=>unsigned)
888   (:translate sb!bignum:%lognot))
889
890 (define-vop (fixnum-to-digit)
891   (:translate sb!bignum:%fixnum-to-digit)
892   (:policy :fast-safe)
893   (:args (fixnum :scs (any-reg)))
894   (:arg-types tagged-num)
895   (:results (digit :scs (unsigned-reg)))
896   (:result-types unsigned-num)
897   (:generator 1
898     (inst srawi digit fixnum 2)))
899
900
901 (define-vop (bignum-floor)
902   (:translate sb!bignum:%floor)
903   (:policy :fast-safe)
904   (:args (num-high :scs (unsigned-reg) :target rem)
905          (num-low :scs (unsigned-reg) :target rem-low)
906          (denom :scs (unsigned-reg) :to (:eval 1)))
907   (:arg-types unsigned-num unsigned-num unsigned-num)
908   (:temporary (:scs (unsigned-reg) :from (:argument 1)) rem-low)
909   (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp)
910   (:results (quo :scs (unsigned-reg) :from (:eval 0))
911             (rem :scs (unsigned-reg) :from (:argument 0)))
912   (:result-types unsigned-num unsigned-num)
913   (:generator 325 ; number of inst assuming targeting works.
914     (move rem num-high)
915     (move rem-low num-low)
916     (flet ((maybe-subtract (&optional (guess temp))
917              (inst subi temp guess 1)
918              (inst and temp temp denom)
919              (inst sub rem rem temp))
920            (sltu (res x y)
921              (inst subfc res y x)
922              (inst subfe res res res)
923              (inst neg res res)))
924       (sltu quo rem denom)
925       (maybe-subtract quo)
926       (dotimes (i 32)
927         (inst slwi rem rem 1)
928         (inst srwi temp rem-low 31)
929         (inst or rem rem temp)
930         (inst slwi rem-low rem-low 1)
931         (sltu temp rem denom)
932         (inst slwi quo quo 1)
933         (inst or quo quo temp)
934         (maybe-subtract)))
935     (inst not quo quo)))
936
937 #|
938
939 (define-vop (bignum-floor)
940   (:translate sb!bignum:%floor)
941   (:policy :fast-safe)
942   (:args (div-high :scs (unsigned-reg) :target rem)
943          (div-low :scs (unsigned-reg) :target quo)
944          (divisor :scs (unsigned-reg)))
945   (:arg-types unsigned-num unsigned-num unsigned-num)
946   (:results (quo :scs (unsigned-reg) :from (:argument 1))
947             (rem :scs (unsigned-reg) :from (:argument 0)))
948   (:result-types unsigned-num unsigned-num)
949   (:generator 300
950     (inst mtmq div-low)
951     (inst div quo div-high divisor)
952     (inst mfmq rem)))
953 |#
954
955 (define-vop (signify-digit)
956   (:translate sb!bignum:%fixnum-digit-with-correct-sign)
957   (:policy :fast-safe)
958   (:args (digit :scs (unsigned-reg) :target res))
959   (:arg-types unsigned-num)
960   (:results (res :scs (any-reg signed-reg)))
961   (:result-types signed-num)
962   (:generator 1
963     (sc-case res
964       (any-reg
965        (inst slwi res digit 2))
966       (signed-reg
967        (move res digit)))))
968
969
970 (define-vop (digit-ashr)
971   (:translate sb!bignum:%ashr)
972   (:policy :fast-safe)
973   (:args (digit :scs (unsigned-reg))
974          (count :scs (unsigned-reg)))
975   (:arg-types unsigned-num positive-fixnum)
976   (:results (result :scs (unsigned-reg)))
977   (:result-types unsigned-num)
978   (:generator 1
979     (inst sraw result digit count)))
980
981 (define-vop (digit-lshr digit-ashr)
982   (:translate sb!bignum:%digit-logical-shift-right)
983   (:generator 1
984     (inst srw result digit count)))
985
986 (define-vop (digit-ashl digit-ashr)
987   (:translate sb!bignum:%ashl)
988   (:generator 1
989     (inst slw result digit count)))
990
991 \f
992 ;;;; Static funs.
993
994 (define-static-fun two-arg-gcd (x y) :translate gcd)
995 (define-static-fun two-arg-lcm (x y) :translate lcm)
996
997 (define-static-fun two-arg-+ (x y) :translate +)
998 (define-static-fun two-arg-- (x y) :translate -)
999 (define-static-fun two-arg-* (x y) :translate *)
1000 (define-static-fun two-arg-/ (x y) :translate /)
1001
1002 (define-static-fun two-arg-< (x y) :translate <)
1003 (define-static-fun two-arg-<= (x y) :translate <=)
1004 (define-static-fun two-arg-> (x y) :translate >)
1005 (define-static-fun two-arg->= (x y) :translate >=)
1006 (define-static-fun two-arg-= (x y) :translate =)
1007 (define-static-fun two-arg-/= (x y) :translate /=)
1008
1009 (define-static-fun %negate (x) :translate %negate)
1010
1011 (define-static-fun two-arg-and (x y) :translate logand)
1012 (define-static-fun two-arg-ior (x y) :translate logior)
1013 (define-static-fun two-arg-xor (x y) :translate logxor)
1014 (define-static-fun two-arg-eqv (x y) :translate logeqv)
1015 \f
1016 (in-package "SB!C")
1017
1018 (deftransform * ((x y)
1019                  ((unsigned-byte 32) (constant-arg (unsigned-byte 32)))
1020                  (unsigned-byte 32))
1021   "recode as shifts and adds"
1022   (let ((y (lvar-value y)))
1023     (multiple-value-bind (result adds shifts)
1024         (ub32-strength-reduce-constant-multiply 'x y)
1025       (cond
1026        ((typep y '(signed-byte 16))
1027         ;; a mulli instruction has a latency of 5.
1028         (when (> (+ adds shifts) 4)
1029           (give-up-ir1-transform)))
1030        (t
1031         ;; a mullw instruction also has a latency of 5, plus two
1032         ;; instructions (in general) to load the immediate into a
1033         ;; register.
1034         (when (> (+ adds shifts) 6)
1035           (give-up-ir1-transform))))
1036       (or result 0))))