1 ;;;; stuff to handle simple cases for generic arithmetic
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 ;;;; Addition and subtraction.
18 ;;; static-fun-offset returns the address of the raw_addr slot of
19 ;;; a static function's fdefn.
21 ;;; Note that there is only one use of static-fun-offset outside this
22 ;;; file (in genesis.lisp)
24 (define-assembly-routine (generic-+
26 (:return-style :full-call)
30 ((:arg x (descriptor-reg any-reg) a0-offset)
31 (:arg y (descriptor-reg any-reg) a1-offset)
33 (:res res (descriptor-reg any-reg) a0-offset)
35 (:temp temp non-descriptor-reg nl0-offset)
36 (:temp temp1 non-descriptor-reg nl1-offset)
37 (:temp temp2 non-descriptor-reg nl2-offset)
38 (:temp pa-flag non-descriptor-reg nl4-offset)
39 (:temp lra descriptor-reg lra-offset)
40 (:temp lip interior-reg lip-offset)
41 (:temp nargs any-reg nargs-offset)
42 (:temp ocfp any-reg ocfp-offset))
44 (inst and temp fixnum-tag-mask)
45 (inst bne temp DO-STATIC-FUN)
48 (inst xor temp1 temp x)
49 (inst xor temp2 temp y)
50 (inst and temp1 temp2)
51 (inst bltz temp1 DO-OVERFLOW)
52 (inst sra temp1 x n-fixnum-tag-bits)
54 (lisp-return lra lip :offset 2)
57 ;; We did overflow, so do the bignum version
58 (inst sra temp2 y n-fixnum-tag-bits)
59 (inst addu temp temp1 temp2)
60 (with-fixed-allocation (res pa-flag temp2 bignum-widetag (1+ bignum-digits-offset))
61 (storew temp res bignum-digits-offset other-pointer-lowtag))
62 (lisp-return lra lip :offset 2)
65 (inst lw lip null-tn (static-fun-offset 'two-arg-+))
66 (inst li nargs (fixnumize 2))
69 (move cfp-tn csp-tn t))
72 (define-assembly-routine (generic--
74 (:return-style :full-call)
78 ((:arg x (descriptor-reg any-reg) a0-offset)
79 (:arg y (descriptor-reg any-reg) a1-offset)
81 (:res res (descriptor-reg any-reg) a0-offset)
83 (:temp temp non-descriptor-reg nl0-offset)
84 (:temp temp1 non-descriptor-reg nl1-offset)
85 (:temp temp2 non-descriptor-reg nl2-offset)
86 (:temp pa-flag non-descriptor-reg nl4-offset)
87 (:temp lra descriptor-reg lra-offset)
88 (:temp lip interior-reg lip-offset)
89 (:temp nargs any-reg nargs-offset)
90 (:temp ocfp any-reg ocfp-offset))
92 (inst and temp fixnum-tag-mask)
93 (inst bne temp DO-STATIC-FUN)
97 (inst xor temp2 x temp)
98 (inst and temp1 temp2)
99 (inst bltz temp1 DO-OVERFLOW)
100 (inst sra temp1 x n-fixnum-tag-bits)
102 (lisp-return lra lip :offset 2)
105 ;; We did overflow, so do the bignum version
106 (inst sra temp2 y n-fixnum-tag-bits)
107 (inst subu temp temp1 temp2)
108 (with-fixed-allocation (res pa-flag temp2 bignum-widetag (1+ bignum-digits-offset))
109 (storew temp res bignum-digits-offset other-pointer-lowtag))
110 (lisp-return lra lip :offset 2)
113 (inst lw lip null-tn (static-fun-offset 'two-arg--))
114 (inst li nargs (fixnumize 2))
117 (move cfp-tn csp-tn t))
124 (define-assembly-routine (generic-*
126 (:return-style :full-call)
130 ((:arg x (descriptor-reg any-reg) a0-offset)
131 (:arg y (descriptor-reg any-reg) a1-offset)
133 (:res res (descriptor-reg any-reg) a0-offset)
135 (:temp temp non-descriptor-reg nl0-offset)
136 (:temp lo non-descriptor-reg nl1-offset)
137 (:temp hi non-descriptor-reg nl2-offset)
138 (:temp pa-flag non-descriptor-reg nl4-offset)
139 (:temp lra descriptor-reg lra-offset)
140 (:temp lip interior-reg lip-offset)
141 (:temp nargs any-reg nargs-offset)
142 (:temp ocfp any-reg ocfp-offset))
143 ;; If either arg is not a fixnum, call the static function.
145 (inst and temp fixnum-tag-mask)
146 (inst bne temp DO-STATIC-FUN)
147 ;; Remove the tag from one arg so that the result will have the correct
149 (inst sra temp x n-fixnum-tag-bits)
153 ;; Check to see if the result will fit in a fixnum. (I.e. the high word
154 ;; is just 32 copies of the sign bit of the low word).
155 (inst sra temp res 31)
156 (inst bne temp hi DO-BIGNUM)
157 (inst srl lo res n-fixnum-tag-bits)
158 (lisp-return lra lip :offset 2)
161 ;; Shift the double word hi:res down two bits into hi:low to get rid of the
163 (inst sll temp hi (- n-word-bits n-fixnum-tag-bits))
165 (inst sra hi n-fixnum-tag-bits)
167 ;; Do we need one word or two? Assume two.
168 (inst sra temp lo 31)
169 (inst bne temp hi TWO-WORDS)
170 ;; Assume a two word header.
171 (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
173 ;; Only need one word, fix the header.
174 (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
176 (pseudo-atomic (pa-flag :extra (pad-data-block (+ 1 bignum-digits-offset)))
177 (inst or res alloc-tn other-pointer-lowtag)
178 (storew temp res 0 other-pointer-lowtag))
179 (storew lo res bignum-digits-offset other-pointer-lowtag)
180 (lisp-return lra lip :offset 2)
183 (pseudo-atomic (pa-flag :extra (pad-data-block (+ 2 bignum-digits-offset)))
184 (inst or res alloc-tn other-pointer-lowtag)
185 (storew temp res 0 other-pointer-lowtag))
187 (storew lo res bignum-digits-offset other-pointer-lowtag)
188 (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
189 (lisp-return lra lip :offset 2)
192 (inst lw lip null-tn (static-fun-offset 'two-arg-*))
193 (inst li nargs (fixnumize 2))
196 (move cfp-tn csp-tn t))
200 ((frob (name note cost type sc signed-p)
201 `(define-assembly-routine (,name
206 (:arg-types ,type ,type)
207 (:result-types ,type))
208 ((:arg x ,sc nl0-offset)
209 (:arg y ,sc nl1-offset)
210 (:res res ,sc nl0-offset))
211 ,@(when (eq type 'tagged-num)
213 (inst ,(if signed-p 'mult 'multu) x y)
215 (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg nil)
216 (frob signed-* "signed *" 41 signed-num signed-reg t)
217 (frob fixnum-* "fixnum *" 30 tagged-num any-reg t))
224 (define-assembly-routine (positive-fixnum-truncate
225 (:note "unsigned fixnum truncate")
227 (:translate truncate)
229 (:arg-types positive-fixnum positive-fixnum)
230 (:result-types positive-fixnum positive-fixnum))
231 ((:arg dividend any-reg nl0-offset)
232 (:arg divisor any-reg nl1-offset)
234 (:res quo any-reg nl2-offset)
235 (:res rem any-reg nl3-offset))
236 (let ((error (generate-error-code nil division-by-zero-error
238 (inst beq divisor error)
241 (inst divu dividend divisor)
247 (define-assembly-routine (fixnum-truncate
248 (:note "fixnum truncate")
251 (:translate truncate)
252 (:arg-types tagged-num tagged-num)
253 (:result-types tagged-num tagged-num))
254 ((:arg dividend any-reg nl0-offset)
255 (:arg divisor any-reg nl1-offset)
257 (:res quo any-reg nl2-offset)
258 (:res rem any-reg nl3-offset))
259 (let ((error (generate-error-code nil division-by-zero-error
261 (inst beq divisor error)
264 (inst div dividend divisor)
270 (define-assembly-routine (signed-truncate
271 (:note "(signed-byte 32) truncate")
274 (:translate truncate)
275 (:arg-types signed-num signed-num)
276 (:result-types signed-num signed-num))
278 ((:arg dividend signed-reg nl0-offset)
279 (:arg divisor signed-reg nl1-offset)
281 (:res quo signed-reg nl2-offset)
282 (:res rem signed-reg nl3-offset))
283 (let ((error (generate-error-code nil division-by-zero-error
285 (inst beq divisor error)
288 (inst div dividend divisor)
294 ;;;; Comparison routines.
297 ((define-cond-assem-rtn (name translate static-fn cmp not-p)
298 `(define-assembly-routine (,name
300 (:return-style :full-call)
302 (:translate ,translate)
304 ((:arg x (descriptor-reg any-reg) a0-offset)
305 (:arg y (descriptor-reg any-reg) a1-offset)
307 (:res res descriptor-reg a0-offset)
309 (:temp temp non-descriptor-reg nl0-offset)
310 (:temp lra descriptor-reg lra-offset)
311 (:temp lip interior-reg lip-offset)
312 (:temp nargs any-reg nargs-offset)
313 (:temp ocfp any-reg ocfp-offset))
315 (inst and temp fixnum-tag-mask)
316 (inst bne temp DO-STATIC-FUN)
319 (inst ,(if not-p 'beq 'bne) temp DONE)
324 (lisp-return lra lip :offset 2)
327 (inst lw lip null-tn (static-fun-offset ',static-fn))
328 (inst li nargs (fixnumize 2))
331 (move cfp-tn csp-tn t))))
333 (define-cond-assem-rtn generic-< < two-arg-< (inst slt temp x y) t)
334 (define-cond-assem-rtn generic-<= <= two-arg-<= (inst slt temp x y) nil)
335 (define-cond-assem-rtn generic-> > two-arg-> (inst slt temp y x) t)
336 (define-cond-assem-rtn generic->= >= two-arg->= (inst slt temp y x) nil))
339 (define-assembly-routine (generic-eql
341 (:return-style :full-call)
345 ((:arg x (descriptor-reg any-reg) a0-offset)
346 (:arg y (descriptor-reg any-reg) a1-offset)
348 (:res res descriptor-reg a0-offset)
350 (:temp temp non-descriptor-reg nl0-offset)
351 (:temp lra descriptor-reg lra-offset)
352 (:temp lip interior-reg lip-offset)
353 (:temp nargs any-reg nargs-offset)
354 (:temp ocfp any-reg ocfp-offset))
355 (inst beq x y RETURN-T)
357 (inst and temp fixnum-tag-mask)
358 (inst bne temp DO-STATIC-FUN)
368 (lisp-return lra lip :offset 2)
371 (inst lw lip null-tn (static-fun-offset 'eql))
372 (inst li nargs (fixnumize 2))
375 (move cfp-tn csp-tn t))
378 (define-assembly-routine (generic-=
380 (:return-style :full-call)
384 ((:arg x (descriptor-reg any-reg) a0-offset)
385 (:arg y (descriptor-reg any-reg) a1-offset)
387 (:res res descriptor-reg a0-offset)
389 (:temp temp non-descriptor-reg nl0-offset)
390 (:temp lra descriptor-reg lra-offset)
391 (:temp lip interior-reg lip-offset)
392 (:temp nargs any-reg nargs-offset)
393 (:temp ocfp any-reg ocfp-offset))
395 (inst and temp fixnum-tag-mask)
396 (inst bne temp DO-STATIC-FUN)
404 (lisp-return lra lip :offset 2)
407 (inst lw lip null-tn (static-fun-offset 'two-arg-=))
408 (inst li nargs (fixnumize 2))
411 (move cfp-tn csp-tn t))
414 (define-assembly-routine (generic-/=
416 (:return-style :full-call)
420 ((:arg x (descriptor-reg any-reg) a0-offset)
421 (:arg y (descriptor-reg any-reg) a1-offset)
423 (:res res descriptor-reg a0-offset)
425 (:temp temp non-descriptor-reg nl0-offset)
426 (:temp lra descriptor-reg lra-offset)
427 (:temp lip interior-reg lip-offset)
428 (:temp nargs any-reg nargs-offset)
429 (:temp ocfp any-reg ocfp-offset))
431 (inst and temp fixnum-tag-mask)
432 (inst bne temp DO-STATIC-FUN)
440 (lisp-return lra lip :offset 2)
443 (inst lw lip null-tn (static-fun-offset 'two-arg-/=))
444 (inst li nargs (fixnumize 2))
447 (move cfp-tn csp-tn t))