5 ;;;; Addition and subtraction.
7 ;;; static-fun-offset returns the address of the raw_addr slot of
8 ;;; a static function's fdefn.
10 ;;; Note that there is only one use of static-fun-offset outside this
11 ;;; file (in genesis.lisp)
13 (define-assembly-routine (generic-+
15 (:return-style :full-call)
19 ((:arg x (descriptor-reg any-reg) a0-offset)
20 (:arg y (descriptor-reg any-reg) a1-offset)
22 (:res res (descriptor-reg any-reg) a0-offset)
24 (:temp temp non-descriptor-reg nl0-offset)
25 (:temp temp1 non-descriptor-reg nl1-offset)
26 (:temp temp2 non-descriptor-reg nl2-offset)
27 (:temp pa-flag non-descriptor-reg nl4-offset)
28 (:temp lra descriptor-reg lra-offset)
29 (:temp lip interior-reg lip-offset)
30 (:temp nargs any-reg nargs-offset)
31 (:temp ocfp any-reg ocfp-offset))
33 (inst and temp fixnum-tag-mask)
34 (inst bne temp DO-STATIC-FUN)
37 (inst xor temp1 temp x)
38 (inst xor temp2 temp y)
39 (inst and temp1 temp2)
40 (inst bltz temp1 DO-OVERFLOW)
41 (inst sra temp1 x n-fixnum-tag-bits)
43 (lisp-return lra lip :offset 2)
46 ;; We did overflow, so do the bignum version
47 (inst sra temp2 y n-fixnum-tag-bits)
48 (inst addu temp temp1 temp2)
49 (with-fixed-allocation (res pa-flag temp2 bignum-widetag (1+ bignum-digits-offset))
50 (storew temp res bignum-digits-offset other-pointer-lowtag))
51 (lisp-return lra lip :offset 2)
54 (inst lw lip null-tn (static-fun-offset 'two-arg-+))
55 (inst li nargs (fixnumize 2))
58 (move cfp-tn csp-tn t))
61 (define-assembly-routine (generic--
63 (:return-style :full-call)
67 ((:arg x (descriptor-reg any-reg) a0-offset)
68 (:arg y (descriptor-reg any-reg) a1-offset)
70 (:res res (descriptor-reg any-reg) a0-offset)
72 (:temp temp non-descriptor-reg nl0-offset)
73 (:temp temp1 non-descriptor-reg nl1-offset)
74 (:temp temp2 non-descriptor-reg nl2-offset)
75 (:temp pa-flag non-descriptor-reg nl4-offset)
76 (:temp lra descriptor-reg lra-offset)
77 (:temp lip interior-reg lip-offset)
78 (:temp nargs any-reg nargs-offset)
79 (:temp ocfp any-reg ocfp-offset))
81 (inst and temp fixnum-tag-mask)
82 (inst bne temp DO-STATIC-FUN)
86 (inst xor temp2 x temp)
87 (inst and temp1 temp2)
88 (inst bltz temp1 DO-OVERFLOW)
89 (inst sra temp1 x n-fixnum-tag-bits)
91 (lisp-return lra lip :offset 2)
94 ;; We did overflow, so do the bignum version
95 (inst sra temp2 y n-fixnum-tag-bits)
96 (inst subu temp temp1 temp2)
97 (with-fixed-allocation (res pa-flag temp2 bignum-widetag (1+ bignum-digits-offset))
98 (storew temp res bignum-digits-offset other-pointer-lowtag))
99 (lisp-return lra lip :offset 2)
102 (inst lw lip null-tn (static-fun-offset 'two-arg--))
103 (inst li nargs (fixnumize 2))
106 (move cfp-tn csp-tn t))
113 (define-assembly-routine (generic-*
115 (:return-style :full-call)
119 ((:arg x (descriptor-reg any-reg) a0-offset)
120 (:arg y (descriptor-reg any-reg) a1-offset)
122 (:res res (descriptor-reg any-reg) a0-offset)
124 (:temp temp non-descriptor-reg nl0-offset)
125 (:temp lo non-descriptor-reg nl1-offset)
126 (:temp hi non-descriptor-reg nl2-offset)
127 (:temp pa-flag non-descriptor-reg nl4-offset)
128 (:temp lra descriptor-reg lra-offset)
129 (:temp lip interior-reg lip-offset)
130 (:temp nargs any-reg nargs-offset)
131 (:temp ocfp any-reg ocfp-offset))
132 ;; If either arg is not a fixnum, call the static function.
134 (inst and temp fixnum-tag-mask)
135 (inst bne temp DO-STATIC-FUN)
136 ;; Remove the tag from one arg so that the result will have the correct
138 (inst sra temp x n-fixnum-tag-bits)
142 ;; Check to see if the result will fit in a fixnum. (I.e. the high word
143 ;; is just 32 copies of the sign bit of the low word).
144 (inst sra temp res 31)
145 (inst bne temp hi DO-BIGNUM)
146 (inst srl lo res n-fixnum-tag-bits)
147 (lisp-return lra lip :offset 2)
150 ;; Shift the double word hi:res down two bits into hi:low to get rid of the
152 (inst sll temp hi (- n-word-bits n-fixnum-tag-bits))
154 (inst sra hi n-fixnum-tag-bits)
156 ;; Do we need one word or two? Assume two.
157 (inst sra temp lo 31)
158 (inst bne temp hi TWO-WORDS)
159 ;; Assume a two word header.
160 (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
162 ;; Only need one word, fix the header.
163 (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
165 (pseudo-atomic (pa-flag :extra (pad-data-block (+ 1 bignum-digits-offset)))
166 (inst or res alloc-tn other-pointer-lowtag)
167 (storew temp res 0 other-pointer-lowtag))
168 (storew lo res bignum-digits-offset other-pointer-lowtag)
169 (lisp-return lra lip :offset 2)
172 (pseudo-atomic (pa-flag :extra (pad-data-block (+ 2 bignum-digits-offset)))
173 (inst or res alloc-tn other-pointer-lowtag)
174 (storew temp res 0 other-pointer-lowtag))
176 (storew lo res bignum-digits-offset other-pointer-lowtag)
177 (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
178 (lisp-return lra lip :offset 2)
181 (inst lw lip null-tn (static-fun-offset 'two-arg-*))
182 (inst li nargs (fixnumize 2))
185 (move cfp-tn csp-tn t))
189 ((frob (name note cost type sc signed-p)
190 `(define-assembly-routine (,name
195 (:arg-types ,type ,type)
196 (:result-types ,type))
197 ((:arg x ,sc nl0-offset)
198 (:arg y ,sc nl1-offset)
199 (:res res ,sc nl0-offset))
200 ,@(when (eq type 'tagged-num)
202 (inst ,(if signed-p 'mult 'multu) x y)
204 (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg nil)
205 (frob signed-* "signed *" 41 signed-num signed-reg t)
206 (frob fixnum-* "fixnum *" 30 tagged-num any-reg t))
213 (define-assembly-routine (positive-fixnum-truncate
214 (:note "unsigned fixnum truncate")
216 (:translate truncate)
218 (:arg-types positive-fixnum positive-fixnum)
219 (:result-types positive-fixnum positive-fixnum))
220 ((:arg dividend any-reg nl0-offset)
221 (:arg divisor any-reg nl1-offset)
223 (:res quo any-reg nl2-offset)
224 (:res rem any-reg nl3-offset))
225 (let ((error (generate-error-code nil division-by-zero-error
227 (inst beq divisor error)
230 (inst divu dividend divisor)
236 (define-assembly-routine (fixnum-truncate
237 (:note "fixnum truncate")
240 (:translate truncate)
241 (:arg-types tagged-num tagged-num)
242 (:result-types tagged-num tagged-num))
243 ((:arg dividend any-reg nl0-offset)
244 (:arg divisor any-reg nl1-offset)
246 (:res quo any-reg nl2-offset)
247 (:res rem any-reg nl3-offset))
248 (let ((error (generate-error-code nil division-by-zero-error
250 (inst beq divisor error)
253 (inst div dividend divisor)
259 (define-assembly-routine (signed-truncate
260 (:note "(signed-byte 32) truncate")
263 (:translate truncate)
264 (:arg-types signed-num signed-num)
265 (:result-types signed-num signed-num))
267 ((:arg dividend signed-reg nl0-offset)
268 (:arg divisor signed-reg nl1-offset)
270 (:res quo signed-reg nl2-offset)
271 (:res rem signed-reg nl3-offset))
272 (let ((error (generate-error-code nil division-by-zero-error
274 (inst beq divisor error)
277 (inst div dividend divisor)
283 ;;;; Comparison routines.
286 ((define-cond-assem-rtn (name translate static-fn cmp not-p)
287 `(define-assembly-routine (,name
289 (:return-style :full-call)
291 (:translate ,translate)
293 ((:arg x (descriptor-reg any-reg) a0-offset)
294 (:arg y (descriptor-reg any-reg) a1-offset)
296 (:res res descriptor-reg a0-offset)
298 (:temp temp non-descriptor-reg nl0-offset)
299 (:temp lra descriptor-reg lra-offset)
300 (:temp lip interior-reg lip-offset)
301 (:temp nargs any-reg nargs-offset)
302 (:temp ocfp any-reg ocfp-offset))
304 (inst and temp fixnum-tag-mask)
305 (inst bne temp DO-STATIC-FUN)
308 (inst ,(if not-p 'beq 'bne) temp DONE)
313 (lisp-return lra lip :offset 2)
316 (inst lw lip null-tn (static-fun-offset ',static-fn))
317 (inst li nargs (fixnumize 2))
320 (move cfp-tn csp-tn t))))
322 (define-cond-assem-rtn generic-< < two-arg-< (inst slt temp x y) t)
323 (define-cond-assem-rtn generic-<= <= two-arg-<= (inst slt temp x y) nil)
324 (define-cond-assem-rtn generic-> > two-arg-> (inst slt temp y x) t)
325 (define-cond-assem-rtn generic->= >= two-arg->= (inst slt temp y x) nil))
328 (define-assembly-routine (generic-eql
330 (:return-style :full-call)
334 ((:arg x (descriptor-reg any-reg) a0-offset)
335 (:arg y (descriptor-reg any-reg) a1-offset)
337 (:res res descriptor-reg a0-offset)
339 (:temp temp non-descriptor-reg nl0-offset)
340 (:temp lra descriptor-reg lra-offset)
341 (:temp lip interior-reg lip-offset)
342 (:temp nargs any-reg nargs-offset)
343 (:temp ocfp any-reg ocfp-offset))
344 (inst beq x y RETURN-T)
346 (inst and temp fixnum-tag-mask)
347 (inst bne temp DO-STATIC-FUN)
357 (lisp-return lra lip :offset 2)
360 (inst lw lip null-tn (static-fun-offset 'eql))
361 (inst li nargs (fixnumize 2))
364 (move cfp-tn csp-tn t))
367 (define-assembly-routine (generic-=
369 (:return-style :full-call)
373 ((:arg x (descriptor-reg any-reg) a0-offset)
374 (:arg y (descriptor-reg any-reg) a1-offset)
376 (:res res descriptor-reg a0-offset)
378 (:temp temp non-descriptor-reg nl0-offset)
379 (:temp lra descriptor-reg lra-offset)
380 (:temp lip interior-reg lip-offset)
381 (:temp nargs any-reg nargs-offset)
382 (:temp ocfp any-reg ocfp-offset))
384 (inst and temp fixnum-tag-mask)
385 (inst bne temp DO-STATIC-FUN)
393 (lisp-return lra lip :offset 2)
396 (inst lw lip null-tn (static-fun-offset 'two-arg-=))
397 (inst li nargs (fixnumize 2))
400 (move cfp-tn csp-tn t))
403 (define-assembly-routine (generic-/=
405 (:return-style :full-call)
409 ((:arg x (descriptor-reg any-reg) a0-offset)
410 (:arg y (descriptor-reg any-reg) a1-offset)
412 (:res res descriptor-reg a0-offset)
414 (:temp temp non-descriptor-reg nl0-offset)
415 (:temp lra descriptor-reg lra-offset)
416 (:temp lip interior-reg lip-offset)
417 (:temp nargs any-reg nargs-offset)
418 (:temp ocfp any-reg ocfp-offset))
420 (inst and temp fixnum-tag-mask)
421 (inst bne temp DO-STATIC-FUN)
429 (lisp-return lra lip :offset 2)
432 (inst lw lip null-tn (static-fun-offset 'two-arg-/=))
433 (inst li nargs (fixnumize 2))
436 (move cfp-tn csp-tn t))