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 zero-tn 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
:unsigned
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
:unsigned
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 logxor t
)
431 (define-modular-backend logeqv t
)
432 (define-modular-backend logandc1
)
433 (define-modular-backend logandc2 t
)
434 (define-modular-backend logorc1
)
435 (define-modular-backend logorc2 t
))
437 (define-source-transform lognand
(x y
)
438 `(lognot (logand ,x
,y
)))
439 (define-source-transform lognor
(x y
)
440 `(lognot (logior ,x
,y
)))
442 ;;;; binary conditional VOPs
444 (define-vop (fast-conditional)
449 (:temporary
(:scs
(non-descriptor-reg)) temp
)
450 (:policy
:fast-safe
))
452 (define-vop (fast-conditional/fixnum fast-conditional
)
453 (:args
(x :scs
(any-reg))
455 (:arg-types tagged-num tagged-num
)
456 (:note
"inline fixnum comparison"))
458 (define-vop (fast-conditional-c/fixnum fast-conditional
/fixnum
)
459 (:args
(x :scs
(any-reg)))
460 (:arg-types tagged-num
(:constant
(unsigned-byte-with-a-bite-out 6 4)))
461 (:info target not-p y
))
463 (define-vop (fast-conditional/signed fast-conditional
)
464 (:args
(x :scs
(signed-reg))
465 (y :scs
(signed-reg)))
466 (:arg-types signed-num signed-num
)
467 (:note
"inline (signed-byte 64) comparison"))
469 (define-vop (fast-conditional-c/signed fast-conditional
/signed
)
470 (:args
(x :scs
(signed-reg)))
471 (:arg-types signed-num
(:constant
(unsigned-byte-with-a-bite-out 8 1)))
472 (:info target not-p y
))
474 (define-vop (fast-conditional/unsigned fast-conditional
)
475 (:args
(x :scs
(unsigned-reg))
476 (y :scs
(unsigned-reg)))
477 (:arg-types unsigned-num unsigned-num
)
478 (:note
"inline (unsigned-byte 64) comparison"))
480 (define-vop (fast-conditional-c/unsigned fast-conditional
/unsigned
)
481 (:args
(x :scs
(unsigned-reg)))
482 (:arg-types unsigned-num
(:constant
(unsigned-byte-with-a-bite-out 8 1)))
483 (:info target not-p y
))
486 (defmacro define-conditional-vop
(translate &rest generator
)
488 ,@(mapcar (lambda (suffix cost signed
)
489 (unless (and (member suffix
'(/fixnum -c
/fixnum
))
491 `(define-vop (,(intern (format nil
"~:@(FAST-IF-~A~A~)"
494 (format nil
"~:@(FAST-CONDITIONAL~A~)"
496 (:translate
,translate
)
498 (let* ((signed ,signed
)
499 (-c/fixnum
,(eq suffix
'-c
/fixnum
))
500 (y (if -c
/fixnum
(fixnumize y
) y
)))
502 '(/fixnum -c
/fixnum
/signed -c
/signed
/unsigned -c
/unsigned
)
504 '(t t t t nil nil
))))
506 (define-conditional-vop <
507 (cond ((and signed
(eql y
0))
510 (inst blt x target
)))
513 (inst cmplt x y temp
)
514 (inst cmpult x y temp
))
516 (inst beq temp target
)
517 (inst bne temp target
)))))
519 (define-conditional-vop >
520 (cond ((and signed
(eql y
0))
523 (inst bgt x target
)))
525 (let ((y (+ y
(if -c
/fixnum
(fixnumize 1) 1))))
527 (inst cmplt x y temp
)
528 (inst cmpult x y temp
))
530 (inst bne temp target
)
531 (inst beq temp target
))))
534 (inst cmplt y x temp
)
535 (inst cmpult y x temp
))
537 (inst beq temp target
)
538 (inst bne temp target
)))))
540 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not
541 ;;; just a known fixnum.
543 (define-conditional-vop eql
544 (declare (ignore signed
))
548 (inst cmpeq x y temp
)
550 (inst beq temp target
)
551 (inst bne temp target
)))
553 ;;; These versions specify a fixnum restriction on their first arg. We
554 ;;; have also generic-eql/fixnum VOPs which are the same, but have no
555 ;;; restriction on the first arg and a higher cost. The reason for
556 ;;; doing this is to prevent fixnum specific operations from being
557 ;;; used on word integers, spuriously consing the argument.
558 (define-vop (fast-eql/fixnum fast-conditional
)
559 (:args
(x :scs
(any-reg))
561 (:arg-types tagged-num tagged-num
)
562 (:note
"inline fixnum comparison")
565 (cond ((equal y zero-tn
)
568 (inst beq x target
)))
570 (inst cmpeq x y temp
)
572 (inst beq temp target
)
573 (inst bne temp target
))))))
576 (define-vop (generic-eql/fixnum fast-eql
/fixnum
)
577 (:args
(x :scs
(any-reg descriptor-reg
))
579 (:arg-types
* tagged-num
)
582 (define-vop (fast-eql-c/fixnum fast-conditional
/fixnum
)
583 (:args
(x :scs
(any-reg)))
584 (:arg-types tagged-num
(:constant
(signed-byte 6)))
585 (:temporary
(:scs
(non-descriptor-reg)) temp
)
586 (:info target not-p y
)
589 (let ((y (cond ((eql y
0) zero-tn
)
591 (inst li
(fixnumize y
) temp
)
593 (inst cmpeq x y temp
)
595 (inst beq temp target
)
596 (inst bne temp target
)))))
598 (define-vop (generic-eql-c/fixnum fast-eql-c
/fixnum
)
599 (:args
(x :scs
(any-reg descriptor-reg
)))
600 (:arg-types
* (:constant
(signed-byte 6)))
604 ;;;; 32-bit logical operations
606 (define-vop (merge-bits)
607 (:translate merge-bits
)
608 (:args
(shift :scs
(signed-reg unsigned-reg
))
609 (prev :scs
(unsigned-reg))
610 (next :scs
(unsigned-reg)))
611 (:arg-types tagged-num unsigned-num unsigned-num
)
612 (:temporary
(:scs
(unsigned-reg) :to
(:result
0)) temp
)
613 (:temporary
(:scs
(unsigned-reg) :to
(:result
0) :target result
) res
)
614 (:results
(result :scs
(unsigned-reg)))
615 (:result-types unsigned-num
)
618 (let ((done (gen-label)))
619 (inst srl next shift res
)
620 (inst beq shift done
)
621 (inst subq zero-tn shift temp
)
622 (inst sll prev temp temp
)
623 (inst bis res temp res
)
627 (define-vop (shift-towards-someplace)
629 (:args
(num :scs
(unsigned-reg))
630 (amount :scs
(signed-reg)))
631 (:arg-types unsigned-num tagged-num
)
632 (:results
(r :scs
(unsigned-reg)))
633 (:result-types unsigned-num
))
635 (define-vop (shift-towards-start shift-towards-someplace
)
636 (:translate shift-towards-start
)
637 (:note
"SHIFT-TOWARDS-START")
638 (:temporary
(:sc non-descriptor-reg
) temp
)
640 (inst and amount
#x1f temp
)
641 (inst srl num temp r
)))
643 (define-vop (shift-towards-end shift-towards-someplace
)
644 (:translate shift-towards-end
)
645 (:note
"SHIFT-TOWARDS-END")
646 (:temporary
(:sc non-descriptor-reg
) temp
)
648 (inst and amount
#x1f temp
)
649 (inst sll num temp r
)))
653 (define-vop (bignum-length get-header-data
)
654 (:translate sb
!bignum
:%bignum-length
)
655 (:policy
:fast-safe
))
657 (define-vop (bignum-set-length set-header-data
)
658 (:translate sb
!bignum
:%bignum-set-length
)
659 (:policy
:fast-safe
))
661 (define-full-reffer bignum-ref
* bignum-digits-offset other-pointer-lowtag
662 (unsigned-reg) unsigned-num sb
!bignum
:%bignum-ref
)
664 (define-full-setter bignum-set
* bignum-digits-offset other-pointer-lowtag
665 (unsigned-reg) unsigned-num sb
!bignum
:%bignum-set
#!+gengc nil
)
667 (define-vop (digit-0-or-plus)
668 (:translate sb
!bignum
:%digit-0-or-plusp
)
670 (:args
(digit :scs
(unsigned-reg)))
671 (:arg-types unsigned-num
)
672 (:temporary
(:sc non-descriptor-reg
) temp
)
676 (inst sll digit
32 temp
)
678 (inst blt temp target
)
679 (inst bge temp target
))))
681 (define-vop (add-w/carry
)
682 (:translate sb
!bignum
:%add-with-carry
)
684 (:args
(a :scs
(unsigned-reg))
685 (b :scs
(unsigned-reg))
686 (c :scs
(unsigned-reg)))
687 (:arg-types unsigned-num unsigned-num positive-fixnum
)
688 (:results
(result :scs
(unsigned-reg) :from
:load
)
689 (carry :scs
(unsigned-reg) :from
:eval
))
690 (:result-types unsigned-num positive-fixnum
)
692 (inst addq a b result
)
693 (inst addq result c result
)
694 (inst sra result
32 carry
)
695 (inst mskll result
4 result
)))
697 (define-vop (sub-w/borrow
)
698 (:translate sb
!bignum
:%subtract-with-borrow
)
700 (:args
(a :scs
(unsigned-reg))
701 (b :scs
(unsigned-reg))
702 (c :scs
(unsigned-reg)))
703 (:arg-types unsigned-num unsigned-num positive-fixnum
)
704 (:results
(result :scs
(unsigned-reg) :from
:load
)
705 (borrow :scs
(unsigned-reg) :from
:eval
))
706 (:result-types unsigned-num positive-fixnum
)
708 (inst xor c
1 result
)
709 (inst subq a result result
)
710 (inst subq result b result
)
711 (inst srl result
63 borrow
)
712 (inst xor borrow
1 borrow
)
713 (inst mskll result
4 result
)))
715 (define-vop (bignum-mult-and-add-3-arg)
716 (:translate sb
!bignum
:%multiply-and-add
)
718 (:args
(x :scs
(unsigned-reg))
719 (y :scs
(unsigned-reg))
720 (carry-in :scs
(unsigned-reg) :to
:save
))
721 (:arg-types unsigned-num unsigned-num unsigned-num
)
722 (:results
(hi :scs
(unsigned-reg))
723 (lo :scs
(unsigned-reg)))
724 (:result-types unsigned-num unsigned-num
)
727 (inst addq lo carry-in lo
)
729 (inst mskll lo
4 lo
)))
732 (define-vop (bignum-mult-and-add-4-arg)
733 (:translate sb
!bignum
:%multiply-and-add
)
735 (:args
(x :scs
(unsigned-reg))
736 (y :scs
(unsigned-reg))
737 (prev :scs
(unsigned-reg))
738 (carry-in :scs
(unsigned-reg) :to
:save
))
739 (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num
)
740 (:results
(hi :scs
(unsigned-reg))
741 (lo :scs
(unsigned-reg)))
742 (:result-types unsigned-num unsigned-num
)
745 (inst addq lo prev lo
)
746 (inst addq lo carry-in lo
)
748 (inst mskll lo
4 lo
)))
750 (define-vop (bignum-mult)
751 (:translate sb
!bignum
:%multiply
)
753 (:args
(x :scs
(unsigned-reg))
754 (y :scs
(unsigned-reg)))
755 (:arg-types unsigned-num unsigned-num
)
756 (:results
(hi :scs
(unsigned-reg))
757 (lo :scs
(unsigned-reg)))
758 (:result-types unsigned-num unsigned-num
)
762 (inst mskll lo
4 lo
)))
764 (define-vop (bignum-lognot)
765 (:translate sb
!bignum
:%lognot
)
767 (:args
(x :scs
(unsigned-reg)))
768 (:arg-types unsigned-num
)
769 (:results
(r :scs
(unsigned-reg)))
770 (:result-types unsigned-num
)
775 (define-vop (fixnum-to-digit)
776 (:translate sb
!bignum
:%fixnum-to-digit
)
778 (:args
(fixnum :scs
(any-reg)))
779 (:arg-types tagged-num
)
780 (:results
(digit :scs
(unsigned-reg)))
781 (:result-types unsigned-num
)
783 (inst sra fixnum n-fixnum-tag-bits digit
)))
785 (define-vop (bignum-floor)
786 (:translate sb
!bignum
:%floor
)
788 (:args
(num-high :scs
(unsigned-reg))
789 (num-low :scs
(unsigned-reg))
790 (denom-arg :scs
(unsigned-reg) :target denom
))
791 (:arg-types unsigned-num unsigned-num unsigned-num
)
792 (:temporary
(:scs
(unsigned-reg) :from
(:argument
2)) denom
)
793 (:temporary
(:scs
(unsigned-reg) :from
(:eval
0)) temp
)
794 (:results
(quo :scs
(unsigned-reg) :from
(:eval
0))
795 (rem :scs
(unsigned-reg) :from
(:argument
0)))
796 (:result-types unsigned-num unsigned-num
)
797 (:generator
325 ; number of inst assuming targeting works.
798 (inst sll num-high
32 rem
)
799 (inst bis rem num-low rem
)
800 (inst sll denom-arg
32 denom
)
801 (inst cmpule denom rem quo
)
802 (inst beq quo shift1
)
803 (inst subq rem denom rem
)
806 (let ((shift2 (gen-label)))
807 (inst srl denom
1 denom
)
808 (inst cmpule denom rem temp
)
810 (inst beq temp shift2
)
811 (inst subq rem denom rem
)
813 (emit-label shift2
)))))
815 (define-vop (signify-digit)
816 (:translate sb
!bignum
:%fixnum-digit-with-correct-sign
)
818 (:args
(digit :scs
(unsigned-reg) :target res
))
819 (:arg-types unsigned-num
)
820 (:results
(res :scs
(any-reg signed-reg
)))
821 (:result-types signed-num
)
825 (inst sll digit
34 res
)
826 (inst sra res
32 res
))
828 (inst sll digit
32 res
)
829 (inst sra res
32 res
)))))
832 (define-vop (digit-ashr)
833 (:translate sb
!bignum
:%ashr
)
835 (:args
(digit :scs
(unsigned-reg))
836 (count :scs
(unsigned-reg)))
837 (:arg-types unsigned-num positive-fixnum
)
838 (:results
(result :scs
(unsigned-reg) :from
(:argument
0)))
839 (:result-types unsigned-num
)
841 (inst sll digit
32 result
)
842 (inst sra result count result
)
843 (inst srl result
32 result
)))
845 (define-vop (digit-lshr digit-ashr
)
846 (:translate sb
!bignum
:%digit-logical-shift-right
)
848 (inst srl digit count result
)))
850 (define-vop (digit-ashl digit-ashr
)
851 (:translate sb
!bignum
:%ashl
)
853 (inst sll digit count result
)))
855 ;;;; static functions
857 (define-static-fun two-arg-gcd
(x y
) :translate gcd
)
858 (define-static-fun two-arg-lcm
(x y
) :translate lcm
)
860 (define-static-fun two-arg-
+ (x y
) :translate
+)
861 (define-static-fun two-arg--
(x y
) :translate -
)
862 (define-static-fun two-arg-
* (x y
) :translate
*)
863 (define-static-fun two-arg-
/ (x y
) :translate
/)
865 (define-static-fun two-arg-
< (x y
) :translate
<)
866 (define-static-fun two-arg-
<= (x y
) :translate
<=)
867 (define-static-fun two-arg-
> (x y
) :translate
>)
868 (define-static-fun two-arg-
>= (x y
) :translate
>=)
869 (define-static-fun two-arg-
= (x y
) :translate
=)
870 (define-static-fun two-arg-
/= (x y
) :translate
/=)
872 (define-static-fun %negate
(x) :translate %negate
)
874 (define-static-fun two-arg-and
(x y
) :translate logand
)
875 (define-static-fun two-arg-ior
(x y
) :translate logior
)
876 (define-static-fun two-arg-xor
(x y
) :translate logxor
)
877 (define-static-fun two-arg-eqv
(x y
) :translate logeqv
)