1 ;;;; the VM definition arithmetic VOPs for the Alpha
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
16 (define-vop (fixnum-unop)
17 (:args
(x :scs
(any-reg)))
18 (:results
(res :scs
(any-reg)))
19 (:note
"inline fixnum arithmetic")
20 (:arg-types tagged-num
)
21 (:result-types tagged-num
)
24 (define-vop (signed-unop)
25 (:args
(x :scs
(signed-reg)))
26 (:results
(res :scs
(signed-reg)))
27 (:note
"inline (signed-byte 64) arithmetic")
28 (:arg-types signed-num
)
29 (:result-types signed-num
)
32 (define-vop (fast-negate/fixnum fixnum-unop
)
35 (inst subq zero-tn x res
)))
37 (define-vop (fast-negate/signed signed-unop
)
40 (inst subq zero-tn x res
)))
42 (define-vop (fast-lognot/fixnum fixnum-unop
)
45 (inst eqv x fixnum-tag-mask res
)))
47 (define-vop (fast-lognot/signed signed-unop
)
52 ;;;; binary fixnum operations
54 ;;; Assume that any constant operand is the second arg...
56 (define-vop (fast-fixnum-binop)
57 (:args
(x :target r
:scs
(any-reg))
58 (y :target r
:scs
(any-reg)))
59 (:arg-types tagged-num tagged-num
)
60 (:results
(r :scs
(any-reg)))
61 (:result-types tagged-num
)
62 (:note
"inline fixnum arithmetic")
67 (define-vop (fast-unsigned-binop)
68 (:args
(x :target r
:scs
(unsigned-reg))
69 (y :target r
:scs
(unsigned-reg)))
70 (:arg-types unsigned-num unsigned-num
)
71 (:results
(r :scs
(unsigned-reg)))
72 (:result-types unsigned-num
)
73 (:note
"inline (unsigned-byte 64) arithmetic")
78 (define-vop (fast-signed-binop)
79 (:args
(x :target r
:scs
(signed-reg))
80 (y :target r
:scs
(signed-reg)))
81 (:arg-types signed-num signed-num
)
82 (:results
(r :scs
(signed-reg)))
83 (:result-types signed-num
)
84 (:note
"inline (signed-byte 64) arithmetic")
89 (define-vop (fast-fixnum-c-binop fast-fixnum-binop
)
90 (:args
(x :target r
:scs
(any-reg)))
92 (:arg-types tagged-num
(:constant integer
)))
94 (define-vop (fast-signed-c-binop fast-signed-binop
)
95 (:args
(x :target r
:scs
(signed-reg)))
97 (:arg-types signed-num
(:constant integer
)))
99 (define-vop (fast-unsigned-c-binop fast-unsigned-binop
)
100 (:args
(x :target r
:scs
(unsigned-reg)))
102 (:arg-types unsigned-num
(:constant integer
)))
104 (defmacro define-binop
(translate cost untagged-cost op
105 tagged-type untagged-type
106 &optional arg-swap restore-fixnum-mask
)
108 (define-vop (,(symbolicate "FAST-" translate
"/FIXNUM=>FIXNUM")
110 ,@(when restore-fixnum-mask
111 `((:temporary
(:sc non-descriptor-reg
) temp
)))
112 (:args
(x ,@(unless restore-fixnum-mask
`(:target r
)) :scs
(any-reg))
113 (y ,@(unless restore-fixnum-mask
`(:target r
)) :scs
(any-reg)))
114 (:translate
,translate
)
115 (:generator
,(1+ cost
)
117 `(inst ,op y x
,(if restore-fixnum-mask
'temp
'r
))
118 `(inst ,op x y
,(if restore-fixnum-mask
'temp
'r
)))
119 ,@(when restore-fixnum-mask
120 `((inst bic temp
#.
(ash lowtag-mask -
1) r
)))))
121 (define-vop (,(symbolicate "FAST-" translate
"/SIGNED=>SIGNED")
123 (:args
(x :target r
:scs
(signed-reg))
124 (y :target r
:scs
(signed-reg)))
125 (:translate
,translate
)
126 (:generator
,(1+ untagged-cost
)
130 (define-vop (,(symbolicate "FAST-" translate
"/UNSIGNED=>UNSIGNED")
132 (:args
(x :target r
:scs
(unsigned-reg))
133 (y :target r
:scs
(unsigned-reg)))
134 (:translate
,translate
)
135 (:generator
,(1+ untagged-cost
)
139 ,@(when (and tagged-type
(not arg-swap
))
140 `((define-vop (,(symbolicate "FAST-" translate
"-C/FIXNUM=>FIXNUM")
142 (:args
(x ,@(unless restore-fixnum-mask
`(:target r
))
144 (:arg-types tagged-num
(:constant
,tagged-type
))
145 ,@(when restore-fixnum-mask
146 `((:temporary
(:sc non-descriptor-reg
) temp
)))
147 (:translate
,translate
)
149 (inst ,op x
(fixnumize y
) ,(if restore-fixnum-mask
'temp
'r
))
150 ,@(when restore-fixnum-mask
151 `((inst bic temp
#.
(ash lowtag-mask -
1) r
)))))))
152 ,@(when (and untagged-type
(not arg-swap
))
153 `((define-vop (,(symbolicate "FAST-" translate
"-C/SIGNED=>SIGNED")
155 (:arg-types signed-num
(:constant
,untagged-type
))
156 (:translate
,translate
)
157 (:generator
,untagged-cost
159 (define-vop (,(symbolicate "FAST-" translate
160 "-C/UNSIGNED=>UNSIGNED")
161 fast-unsigned-c-binop
)
162 (:arg-types unsigned-num
(:constant
,untagged-type
))
163 (:translate
,translate
)
164 (:generator
,untagged-cost
165 (inst ,op x y r
)))))))
167 (define-binop + 1 5 addq
(unsigned-byte 6) (unsigned-byte 8))
168 (define-binop -
1 5 subq
(unsigned-byte 6) (unsigned-byte 8))
169 (define-binop logand
1 3 and
(unsigned-byte 6) (unsigned-byte 8))
170 (define-binop logandc1
1 3 bic
(unsigned-byte 6) (unsigned-byte 8) t
)
171 (define-binop logandc2
1 3 bic
(unsigned-byte 6) (unsigned-byte 8))
172 (define-binop logior
1 3 bis
(unsigned-byte 6) (unsigned-byte 8))
173 (define-binop logorc1
1 3 ornot
(unsigned-byte 6) (unsigned-byte 8) t t
)
174 (define-binop logorc2
1 3 ornot
(unsigned-byte 6) (unsigned-byte 8) nil t
)
175 (define-binop logxor
1 3 xor
(unsigned-byte 6) (unsigned-byte 8))
176 (define-binop logeqv
1 3 eqv
(unsigned-byte 6) (unsigned-byte 8) nil t
)
178 ;;; special cases for LOGAND where we can use a mask operation
179 (define-vop (fast-logand-c-mask/unsigned
=>unsigned fast-unsigned-c-binop
)
181 (:arg-types unsigned-num
182 (:constant
(or (integer #xffffffff
#xffffffff
)
183 (integer #xffffffff00000000
#xffffffff00000000
))))
186 (#xffffffff
(inst mskll x
4 r
))
187 (#xffffffff00000000
(inst mskll x
0 r
)))))
191 (define-vop (fast-ash/unsigned
=>unsigned
)
193 (:args
(number :scs
(unsigned-reg) :to
:save
)
194 (amount :scs
(signed-reg)))
195 (:arg-types unsigned-num signed-num
)
196 (:results
(result :scs
(unsigned-reg)))
197 (:result-types unsigned-num
)
200 (:temporary
(:sc non-descriptor-reg
) ndesc
)
201 (:temporary
(:sc non-descriptor-reg
) temp
)
203 (inst bge amount positive
)
204 (inst subq zero-tn amount ndesc
)
205 (inst cmplt ndesc
64 temp
)
206 (inst srl number ndesc result
)
207 ;; FIXME: this looks like a candidate for a conditional move --
210 (move zero-tn result
)
211 (inst br zero-tn done
)
214 (inst sll number amount result
)
218 (define-vop (fast-ash/signed
=>signed
)
220 (:args
(number :scs
(signed-reg) :to
:save
)
221 (amount :scs
(signed-reg)))
222 (:arg-types signed-num signed-num
)
223 (:results
(result :scs
(signed-reg)))
224 (:result-types signed-num
)
227 (:temporary
(:sc non-descriptor-reg
) ndesc
)
228 (:temporary
(:sc non-descriptor-reg
) temp
)
230 (inst bge amount positive
)
231 (inst subq zero-tn amount ndesc
)
232 (inst cmplt ndesc
63 temp
)
233 (inst sra number ndesc result
)
235 (inst sra number
63 result
)
236 (inst br zero-tn done
)
239 (inst sll number amount result
)
243 (define-vop (fast-ash-c/signed
=>signed
)
247 (:args
(number :scs
(signed-reg)))
249 (:arg-types signed-num
(:constant integer
))
250 (:results
(result :scs
(signed-reg)))
251 (:result-types signed-num
)
254 ((< count
0) (inst sra number
(min 63 (- count
)) result
))
255 ((> count
0) (inst sll number
(min 63 count
) result
))
256 (t (bug "identity ASH not transformed away")))))
258 (define-vop (fast-ash-c/unsigned
=>unsigned
)
262 (:args
(number :scs
(unsigned-reg)))
264 (:arg-types unsigned-num
(:constant integer
))
265 (:results
(result :scs
(unsigned-reg)))
266 (:result-types unsigned-num
)
269 ((< count -
63) (move zero-tn result
))
270 ((< count
0) (inst sra number
(- count
) result
))
271 ((> count
0) (inst sll number
(min 63 count
) result
))
272 (t (bug "identity ASH not transformed away")))))
274 (macrolet ((def (name sc-type type result-type cost
)
278 (:args
(number :scs
(,sc-type
))
279 (amount :scs
(signed-reg unsigned-reg immediate
)))
280 (:arg-types
,type positive-fixnum
)
281 (:results
(result :scs
(,result-type
)))
282 (:result-types
,type
)
286 ((signed-reg unsigned-reg
)
287 (inst sll number amount result
))
289 (let ((amount (tn-value amount
)))
291 (inst sll number amount result
))))))))
292 (def fast-ash-left
/fixnum
=>fixnum any-reg tagged-num any-reg
2)
293 (def fast-ash-left
/signed
=>signed signed-reg signed-num signed-reg
3)
294 (def fast-ash-left
/unsigned
=>unsigned unsigned-reg unsigned-num unsigned-reg
3))
296 (define-vop (signed-byte-64-len)
297 (:translate integer-length
)
298 (:note
"inline (signed-byte 64) integer-length")
300 (:args
(arg :scs
(signed-reg) :to
(:argument
1)))
301 (:arg-types signed-num
)
302 (:results
(res :scs
(any-reg)))
303 (:result-types positive-fixnum
)
304 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
0)) shift
)
307 (inst cmovge arg arg shift
)
308 (inst subq zero-tn
(fixnumize 1) res
)
309 (inst sll shift
1 shift
)
311 (inst addq res
(fixnumize 1) res
)
312 (inst srl shift
1 shift
)
313 (inst bne shift loop
)))
315 (define-vop (unsigned-byte-64-count)
316 (:translate logcount
)
317 (:note
"inline (unsigned-byte 64) logcount")
319 (:args
(arg :scs
(unsigned-reg)))
320 (:arg-types unsigned-num
)
321 (:results
(res :scs
(unsigned-reg)))
322 (:result-types positive-fixnum
)
323 (:guard
(member :cix
*backend-subfeatures
*))
325 (inst ctpop zero-tn arg res
)))
327 (define-vop (unsigned-byte-64-count)
328 (:translate logcount
)
329 (:note
"inline (unsigned-byte 64) logcount")
331 (:args
(arg :scs
(unsigned-reg) :target num
))
332 (:arg-types unsigned-num
)
333 (:results
(res :scs
(unsigned-reg)))
334 (:result-types positive-fixnum
)
335 (:temporary
(:scs
(non-descriptor-reg) :from
(:argument
0) :to
(:result
0)
337 (:temporary
(:scs
(non-descriptor-reg)) mask temp
)
339 ;; FIXME: now this looks expensive, what with these 64bit loads.
340 ;; Maybe a loop and count would be faster? -- CSR, 2003-09-10
341 (inst li
#x5555555555555555 mask
)
342 (inst srl arg
1 temp
)
343 (inst and arg mask num
)
344 (inst and temp mask temp
)
345 (inst addq num temp num
)
346 (inst li
#x3333333333333333 mask
)
347 (inst srl num
2 temp
)
348 (inst and num mask num
)
349 (inst and temp mask temp
)
350 (inst addq num temp num
)
351 (inst li
#x0f0f0f0f0f0f0f0f mask
)
352 (inst srl num
4 temp
)
353 (inst and num mask num
)
354 (inst and temp mask temp
)
355 (inst addq num temp num
)
356 (inst li
#x00ff00ff00ff00ff mask
)
357 (inst srl num
8 temp
)
358 (inst and num mask num
)
359 (inst and temp mask temp
)
360 (inst addq num temp num
)
361 (inst li
#x0000ffff0000ffff mask
)
362 (inst srl num
16 temp
)
363 (inst and num mask num
)
364 (inst and temp mask temp
)
365 (inst addq num temp num
)
366 (inst li
#x00000000ffffffff mask
)
367 (inst srl num
32 temp
)
368 (inst and num mask num
)
369 (inst and temp mask temp
)
370 (inst addq num temp res
)))
374 (define-vop (fast-*/fixnum
=>fixnum fast-fixnum-binop
)
375 (:temporary
(:scs
(non-descriptor-reg)) temp
)
378 (inst sra y n-fixnum-tag-bits temp
)
379 (inst mulq x temp r
)))
381 (define-vop (fast-*/signed
=>signed fast-signed-binop
)
386 (define-vop (fast-*/unsigned
=>unsigned fast-unsigned-binop
)
391 ;;;; Modular functions:
392 (define-modular-fun lognot-mod64
(x) lognot
:untagged nil
64)
393 (define-vop (lognot-mod64/unsigned
=>unsigned
)
394 (:translate lognot-mod64
)
395 (:args
(x :scs
(unsigned-reg)))
396 (:arg-types unsigned-num
)
397 (:results
(res :scs
(unsigned-reg)))
398 (:result-types unsigned-num
)
403 (define-vop (fast-ash-left-mod64-c/unsigned
=>unsigned
404 fast-ash-c
/unsigned
=>unsigned
)
405 (:translate ash-left-mod64
))
406 (define-vop (fast-ash-left-mod64/unsigned
=>unsigned
407 fast-ash-left
/unsigned
=>unsigned
))
408 (deftransform ash-left-mod64
((integer count
)
409 ((unsigned-byte 64) (unsigned-byte 6)))
410 (when (sb!c
::constant-lvar-p count
)
411 (sb!c
::give-up-ir1-transform
))
412 '(%primitive fast-ash-left-mod64
/unsigned
=>unsigned integer count
))
415 ((define-modular-backend (fun &optional constantp
)
416 (let ((mfun-name (symbolicate fun
'-mod64
))
417 (modvop (symbolicate 'fast- fun
'-mod64
/unsigned
=>unsigned
))
418 (modcvop (symbolicate 'fast- fun
'-mod64-c
/unsigned
=>unsigned
))
419 (vop (symbolicate 'fast- fun
'/unsigned
=>unsigned
))
420 (cvop (symbolicate 'fast- fun
'-c
/unsigned
=>unsigned
)))
422 (define-modular-fun ,mfun-name
(x y
) ,fun
:untagged nil
64)
423 (define-vop (,modvop
,vop
)
424 (:translate
,mfun-name
))
426 `((define-vop (,modcvop
,cvop
)
427 (:translate
,mfun-name
))))))))
428 (define-modular-backend + t
)
429 (define-modular-backend - t
)
430 (define-modular-backend logeqv t
)
431 (define-modular-backend logandc1
)
432 (define-modular-backend logandc2 t
)
433 (define-modular-backend logorc1
)
434 (define-modular-backend logorc2 t
))
436 (define-source-transform lognand
(x y
)
437 `(lognot (logand ,x
,y
)))
438 (define-source-transform lognor
(x y
)
439 `(lognot (logior ,x
,y
)))
441 ;;;; binary conditional VOPs
443 (define-vop (fast-conditional)
448 (:temporary
(:scs
(non-descriptor-reg)) temp
)
449 (:policy
:fast-safe
))
451 (define-vop (fast-conditional/fixnum fast-conditional
)
452 (:args
(x :scs
(any-reg))
454 (:arg-types tagged-num tagged-num
)
455 (:note
"inline fixnum comparison"))
457 (define-vop (fast-conditional-c/fixnum fast-conditional
/fixnum
)
458 (:args
(x :scs
(any-reg)))
459 (:arg-types tagged-num
(:constant
(unsigned-byte-with-a-bite-out 6 4)))
460 (:info target not-p y
))
462 (define-vop (fast-conditional/signed fast-conditional
)
463 (:args
(x :scs
(signed-reg))
464 (y :scs
(signed-reg)))
465 (:arg-types signed-num signed-num
)
466 (:note
"inline (signed-byte 64) comparison"))
468 (define-vop (fast-conditional-c/signed fast-conditional
/signed
)
469 (:args
(x :scs
(signed-reg)))
470 (:arg-types signed-num
(:constant
(unsigned-byte-with-a-bite-out 8 1)))
471 (:info target not-p y
))
473 (define-vop (fast-conditional/unsigned fast-conditional
)
474 (:args
(x :scs
(unsigned-reg))
475 (y :scs
(unsigned-reg)))
476 (:arg-types unsigned-num unsigned-num
)
477 (:note
"inline (unsigned-byte 64) comparison"))
479 (define-vop (fast-conditional-c/unsigned fast-conditional
/unsigned
)
480 (:args
(x :scs
(unsigned-reg)))
481 (:arg-types unsigned-num
(:constant
(unsigned-byte-with-a-bite-out 8 1)))
482 (:info target not-p y
))
485 (defmacro define-conditional-vop
(translate &rest generator
)
487 ,@(mapcar (lambda (suffix cost signed
)
488 (unless (and (member suffix
'(/fixnum -c
/fixnum
))
490 `(define-vop (,(intern (format nil
"~:@(FAST-IF-~A~A~)"
493 (format nil
"~:@(FAST-CONDITIONAL~A~)"
495 (:translate
,translate
)
497 (let* ((signed ,signed
)
498 (-c/fixnum
,(eq suffix
'-c
/fixnum
))
499 (y (if -c
/fixnum
(fixnumize y
) y
)))
501 '(/fixnum -c
/fixnum
/signed -c
/signed
/unsigned -c
/unsigned
)
503 '(t t t t nil nil
))))
505 (define-conditional-vop <
506 (cond ((and signed
(eql y
0))
509 (inst blt x target
)))
512 (inst cmplt x y temp
)
513 (inst cmpult x y temp
))
515 (inst beq temp target
)
516 (inst bne temp target
)))))
518 (define-conditional-vop >
519 (cond ((and signed
(eql y
0))
522 (inst bgt x target
)))
524 (let ((y (+ y
(if -c
/fixnum
(fixnumize 1) 1))))
526 (inst cmplt x y temp
)
527 (inst cmpult x y temp
))
529 (inst bne temp target
)
530 (inst beq temp target
))))
533 (inst cmplt y x temp
)
534 (inst cmpult y x temp
))
536 (inst beq temp target
)
537 (inst bne temp target
)))))
539 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not
540 ;;; just a known fixnum.
542 (define-conditional-vop eql
543 (declare (ignore signed
))
547 (inst cmpeq x y temp
)
549 (inst beq temp target
)
550 (inst bne temp target
)))
552 ;;; These versions specify a fixnum restriction on their first arg. We
553 ;;; have also generic-eql/fixnum VOPs which are the same, but have no
554 ;;; restriction on the first arg and a higher cost. The reason for
555 ;;; doing this is to prevent fixnum specific operations from being
556 ;;; used on word integers, spuriously consing the argument.
557 (define-vop (fast-eql/fixnum fast-conditional
)
558 (:args
(x :scs
(any-reg))
560 (:arg-types tagged-num tagged-num
)
561 (:note
"inline fixnum comparison")
564 (cond ((equal y zero-tn
)
567 (inst beq x target
)))
569 (inst cmpeq x y temp
)
571 (inst beq temp target
)
572 (inst bne temp target
))))))
575 (define-vop (generic-eql/fixnum fast-eql
/fixnum
)
576 (:args
(x :scs
(any-reg descriptor-reg
))
578 (:arg-types
* tagged-num
)
581 (define-vop (fast-eql-c/fixnum fast-conditional
/fixnum
)
582 (:args
(x :scs
(any-reg)))
583 (:arg-types tagged-num
(:constant
(signed-byte 6)))
584 (:temporary
(:scs
(non-descriptor-reg)) temp
)
585 (:info target not-p y
)
588 (let ((y (cond ((eql y
0) zero-tn
)
590 (inst li
(fixnumize y
) temp
)
592 (inst cmpeq x y temp
)
594 (inst beq temp target
)
595 (inst bne temp target
)))))
597 (define-vop (generic-eql-c/fixnum fast-eql-c
/fixnum
)
598 (:args
(x :scs
(any-reg descriptor-reg
)))
599 (:arg-types
* (:constant
(signed-byte 6)))
603 ;;;; 32-bit logical operations
605 (define-vop (shift-towards-someplace)
607 (:args
(num :scs
(unsigned-reg))
608 (amount :scs
(signed-reg)))
609 (:arg-types unsigned-num tagged-num
)
610 (:results
(r :scs
(unsigned-reg)))
611 (:result-types unsigned-num
))
613 (define-vop (shift-towards-start shift-towards-someplace
)
614 (:translate shift-towards-start
)
615 (:note
"SHIFT-TOWARDS-START")
616 (:temporary
(:sc non-descriptor-reg
) temp
)
618 (inst and amount
#x1f temp
)
619 (inst srl num temp r
)))
621 (define-vop (shift-towards-end shift-towards-someplace
)
622 (:translate shift-towards-end
)
623 (:note
"SHIFT-TOWARDS-END")
624 (:temporary
(:sc non-descriptor-reg
) temp
)
626 (inst and amount
#x1f temp
)
627 (inst sll num temp r
)))
631 (define-vop (bignum-length get-header-data
)
632 (:translate sb
!bignum
:%bignum-length
)
633 (:policy
:fast-safe
))
635 (define-vop (bignum-set-length set-header-data
)
636 (:translate sb
!bignum
:%bignum-set-length
)
637 (:policy
:fast-safe
))
639 (define-full-reffer bignum-ref
* bignum-digits-offset other-pointer-lowtag
640 (unsigned-reg) unsigned-num sb
!bignum
:%bignum-ref
)
642 (define-full-setter bignum-set
* bignum-digits-offset other-pointer-lowtag
643 (unsigned-reg) unsigned-num sb
!bignum
:%bignum-set
#!+gengc nil
)
645 (define-vop (digit-0-or-plus)
646 (:translate sb
!bignum
:%digit-0-or-plusp
)
648 (:args
(digit :scs
(unsigned-reg)))
649 (:arg-types unsigned-num
)
650 (:temporary
(:sc non-descriptor-reg
) temp
)
654 (inst sll digit
32 temp
)
656 (inst blt temp target
)
657 (inst bge temp target
))))
659 (define-vop (add-w/carry
)
660 (:translate sb
!bignum
:%add-with-carry
)
662 (:args
(a :scs
(unsigned-reg))
663 (b :scs
(unsigned-reg))
664 (c :scs
(unsigned-reg)))
665 (:arg-types unsigned-num unsigned-num positive-fixnum
)
666 (:results
(result :scs
(unsigned-reg) :from
:load
)
667 (carry :scs
(unsigned-reg) :from
:eval
))
668 (:result-types unsigned-num positive-fixnum
)
670 (inst addq a b result
)
671 (inst addq result c result
)
672 (inst sra result
32 carry
)
673 (inst mskll result
4 result
)))
675 (define-vop (sub-w/borrow
)
676 (:translate sb
!bignum
:%subtract-with-borrow
)
678 (:args
(a :scs
(unsigned-reg))
679 (b :scs
(unsigned-reg))
680 (c :scs
(unsigned-reg)))
681 (:arg-types unsigned-num unsigned-num positive-fixnum
)
682 (:results
(result :scs
(unsigned-reg) :from
:load
)
683 (borrow :scs
(unsigned-reg) :from
:eval
))
684 (:result-types unsigned-num positive-fixnum
)
686 (inst xor c
1 result
)
687 (inst subq a result result
)
688 (inst subq result b result
)
689 (inst srl result
63 borrow
)
690 (inst xor borrow
1 borrow
)
691 (inst mskll result
4 result
)))
693 (define-vop (bignum-mult-and-add-3-arg)
694 (:translate sb
!bignum
:%multiply-and-add
)
696 (:args
(x :scs
(unsigned-reg))
697 (y :scs
(unsigned-reg))
698 (carry-in :scs
(unsigned-reg) :to
:save
))
699 (:arg-types unsigned-num unsigned-num unsigned-num
)
700 (:results
(hi :scs
(unsigned-reg))
701 (lo :scs
(unsigned-reg)))
702 (:result-types unsigned-num unsigned-num
)
705 (inst addq lo carry-in lo
)
707 (inst mskll lo
4 lo
)))
710 (define-vop (bignum-mult-and-add-4-arg)
711 (:translate sb
!bignum
:%multiply-and-add
)
713 (:args
(x :scs
(unsigned-reg))
714 (y :scs
(unsigned-reg))
715 (prev :scs
(unsigned-reg))
716 (carry-in :scs
(unsigned-reg) :to
:save
))
717 (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num
)
718 (:results
(hi :scs
(unsigned-reg))
719 (lo :scs
(unsigned-reg)))
720 (:result-types unsigned-num unsigned-num
)
723 (inst addq lo prev lo
)
724 (inst addq lo carry-in lo
)
726 (inst mskll lo
4 lo
)))
728 (define-vop (bignum-mult)
729 (:translate sb
!bignum
:%multiply
)
731 (:args
(x :scs
(unsigned-reg))
732 (y :scs
(unsigned-reg)))
733 (:arg-types unsigned-num unsigned-num
)
734 (:results
(hi :scs
(unsigned-reg))
735 (lo :scs
(unsigned-reg)))
736 (:result-types unsigned-num unsigned-num
)
740 (inst mskll lo
4 lo
)))
742 (define-vop (bignum-lognot)
743 (:translate sb
!bignum
:%lognot
)
745 (:args
(x :scs
(unsigned-reg)))
746 (:arg-types unsigned-num
)
747 (:results
(r :scs
(unsigned-reg)))
748 (:result-types unsigned-num
)
753 (define-vop (fixnum-to-digit)
754 (:translate sb
!bignum
:%fixnum-to-digit
)
756 (:args
(fixnum :scs
(any-reg)))
757 (:arg-types tagged-num
)
758 (:results
(digit :scs
(unsigned-reg)))
759 (:result-types unsigned-num
)
761 (inst sra fixnum n-fixnum-tag-bits digit
)))
763 (define-vop (bignum-floor)
764 (:translate sb
!bignum
:%bigfloor
)
766 (:args
(num-high :scs
(unsigned-reg))
767 (num-low :scs
(unsigned-reg))
768 (denom-arg :scs
(unsigned-reg) :target denom
))
769 (:arg-types unsigned-num unsigned-num unsigned-num
)
770 (:temporary
(:scs
(unsigned-reg) :from
(:argument
2)) denom
)
771 (:temporary
(:scs
(unsigned-reg) :from
(:eval
0)) temp
)
772 (:results
(quo :scs
(unsigned-reg) :from
(:eval
0))
773 (rem :scs
(unsigned-reg) :from
(:argument
0)))
774 (:result-types unsigned-num unsigned-num
)
775 (:generator
325 ; number of inst assuming targeting works.
776 (inst sll num-high
32 rem
)
777 (inst bis rem num-low rem
)
778 (inst sll denom-arg
32 denom
)
779 (inst cmpule denom rem quo
)
780 (inst beq quo shift1
)
781 (inst subq rem denom rem
)
784 (let ((shift2 (gen-label)))
785 (inst srl denom
1 denom
)
786 (inst cmpule denom rem temp
)
788 (inst beq temp shift2
)
789 (inst subq rem denom rem
)
791 (emit-label shift2
)))))
793 (define-vop (signify-digit)
794 (:translate sb
!bignum
:%fixnum-digit-with-correct-sign
)
796 (:args
(digit :scs
(unsigned-reg) :target res
))
797 (:arg-types unsigned-num
)
798 (:results
(res :scs
(any-reg signed-reg
)))
799 (:result-types signed-num
)
803 (inst sll digit
34 res
)
804 (inst sra res
32 res
))
806 (inst sll digit
32 res
)
807 (inst sra res
32 res
)))))
810 (define-vop (digit-ashr)
811 (:translate sb
!bignum
:%ashr
)
813 (:args
(digit :scs
(unsigned-reg))
814 (count :scs
(unsigned-reg)))
815 (:arg-types unsigned-num positive-fixnum
)
816 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)))
817 (:result-types unsigned-num
)
819 (inst sll digit
32 result
)
820 (inst sra result count result
)
821 (inst srl result
32 result
)))
823 (define-vop (digit-lshr digit-ashr
)
824 (:translate sb
!bignum
:%digit-logical-shift-right
)
826 (inst srl digit count result
)))
828 (define-vop (digit-ashl digit-ashr
)
829 (:translate sb
!bignum
:%ashl
)
831 (inst sll digit count result
)))
833 ;;;; static functions
835 (define-static-fun two-arg-gcd
(x y
) :translate gcd
)
836 (define-static-fun two-arg-lcm
(x y
) :translate lcm
)
838 (define-static-fun two-arg-
+ (x y
) :translate
+)
839 (define-static-fun two-arg--
(x y
) :translate -
)
840 (define-static-fun two-arg-
* (x y
) :translate
*)
841 (define-static-fun two-arg-
/ (x y
) :translate
/)
843 (define-static-fun two-arg-
< (x y
) :translate
<)
844 (define-static-fun two-arg-
<= (x y
) :translate
<=)
845 (define-static-fun two-arg-
> (x y
) :translate
>)
846 (define-static-fun two-arg-
>= (x y
) :translate
>=)
847 (define-static-fun two-arg-
= (x y
) :translate
=)
848 (define-static-fun two-arg-
/= (x y
) :translate
/=)
850 (define-static-fun %negate
(x) :translate %negate
)
852 (define-static-fun two-arg-and
(x y
) :translate logand
)
853 (define-static-fun two-arg-ior
(x y
) :translate logior
)
854 (define-static-fun two-arg-xor
(x y
) :translate logxor
)
855 (define-static-fun two-arg-eqv
(x y
) :translate logeqv
)