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 lip interior-reg lip-offset)
29 (:temp nargs any-reg nargs-offset)
30 (:temp ocfp any-reg ocfp-offset))
32 (inst and temp fixnum-tag-mask)
33 (inst beq temp DO-ADD)
34 (inst sra temp1 x n-fixnum-tag-bits)
37 (inst lw lip null-tn (static-fun-offset 'two-arg-+))
38 (inst li nargs (fixnumize 2))
41 (move cfp-tn csp-tn t)
44 (inst sra temp2 y n-fixnum-tag-bits)
45 (inst addu temp temp1 temp2)
47 (inst sra temp1 temp (- n-word-bits n-lowtag-bits))
48 (inst beq temp1 RETURN)
49 (inst nor temp1 temp1)
50 (inst beq temp1 RETURN)
52 (with-fixed-allocation (res pa-flag temp2 bignum-widetag (1+ bignum-digits-offset))
53 (storew temp res bignum-digits-offset other-pointer-lowtag))
58 (inst sll res temp n-fixnum-tag-bits)
63 (define-assembly-routine (generic--
65 (:return-style :full-call)
69 ((:arg x (descriptor-reg any-reg) a0-offset)
70 (:arg y (descriptor-reg any-reg) a1-offset)
72 (:res res (descriptor-reg any-reg) a0-offset)
74 (:temp temp non-descriptor-reg nl0-offset)
75 (:temp temp1 non-descriptor-reg nl1-offset)
76 (:temp temp2 non-descriptor-reg nl2-offset)
77 (:temp pa-flag non-descriptor-reg nl4-offset)
78 (:temp lip interior-reg lip-offset)
79 (:temp nargs any-reg nargs-offset)
80 (:temp ocfp any-reg ocfp-offset))
82 (inst and temp fixnum-tag-mask)
83 (inst beq temp DO-SUB)
84 (inst sra temp1 x n-fixnum-tag-bits)
87 (inst lw lip null-tn (static-fun-offset 'two-arg--))
88 (inst li nargs (fixnumize 2))
91 (move cfp-tn csp-tn t)
94 (inst sra temp2 y n-fixnum-tag-bits)
95 (inst subu temp temp1 temp2)
97 (inst sra temp1 temp (- n-word-bits n-lowtag-bits))
98 (inst beq temp1 RETURN)
99 (inst nor temp1 temp1)
100 (inst beq temp1 RETURN)
102 (with-fixed-allocation (res pa-flag temp2 bignum-widetag (1+ bignum-digits-offset))
103 (storew temp res bignum-digits-offset other-pointer-lowtag))
108 (inst sll res temp n-fixnum-tag-bits)
117 (define-assembly-routine (generic-*
119 (:return-style :full-call)
123 ((:arg x (descriptor-reg any-reg) a0-offset)
124 (:arg y (descriptor-reg any-reg) a1-offset)
126 (:res res (descriptor-reg any-reg) a0-offset)
128 (:temp temp non-descriptor-reg nl0-offset)
129 (:temp lo non-descriptor-reg nl1-offset)
130 (:temp hi non-descriptor-reg nl2-offset)
131 (:temp pa-flag non-descriptor-reg nl4-offset)
132 (:temp lip interior-reg lip-offset)
133 (:temp nargs any-reg nargs-offset)
134 (:temp ocfp any-reg ocfp-offset))
135 ;; If either arg is not a fixnum, call the static function.
137 (inst and temp fixnum-tag-mask)
138 (inst bne temp DO-STATIC-FUN)
139 ;; Remove the tag from one arg so that the result will have the correct
141 (inst sra temp x n-fixnum-tag-bits)
145 ;; Check to see if the result will fit in a fixnum. (I.e. the high word
146 ;; is just 32 copies of the sign bit of the low word).
147 (inst sra temp res 31)
148 (inst beq temp hi DONE)
149 ;; Shift the double word hi:res down two bits into hi:low to get rid of the
151 (inst srl lo res n-fixnum-tag-bits)
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))
169 (storew lo res bignum-digits-offset other-pointer-lowtag)
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)
178 (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
181 (inst lw lip null-tn (static-fun-offset 'two-arg-*))
182 (inst li nargs (fixnumize 2))
185 (move cfp-tn csp-tn t)
190 ((frob (name note cost type sc signed-p)
191 `(define-assembly-routine (,name
196 (:arg-types ,type ,type)
197 (:result-types ,type))
198 ((:arg x ,sc nl0-offset)
199 (:arg y ,sc nl1-offset)
200 (:res res ,sc nl0-offset))
201 ,@(when (eq type 'tagged-num)
203 (inst ,(if signed-p 'mult 'multu) x y)
205 (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg nil)
206 (frob signed-* "signed *" 41 signed-num signed-reg t)
207 (frob fixnum-* "fixnum *" 30 tagged-num any-reg t))
214 (define-assembly-routine (positive-fixnum-truncate
215 (:note "unsigned fixnum truncate")
217 (:translate truncate)
219 (:arg-types positive-fixnum positive-fixnum)
220 (:result-types positive-fixnum positive-fixnum))
221 ((:arg dividend any-reg nl0-offset)
222 (:arg divisor any-reg nl1-offset)
224 (:res quo any-reg nl2-offset)
225 (:res rem any-reg nl3-offset))
226 (let ((error (generate-error-code nil division-by-zero-error
228 (inst beq divisor error)
231 (inst divu dividend divisor)
237 (define-assembly-routine (fixnum-truncate
238 (:note "fixnum truncate")
241 (:translate truncate)
242 (:arg-types tagged-num tagged-num)
243 (:result-types tagged-num tagged-num))
244 ((:arg dividend any-reg nl0-offset)
245 (:arg divisor any-reg nl1-offset)
247 (:res quo any-reg nl2-offset)
248 (:res rem any-reg nl3-offset))
249 (let ((error (generate-error-code nil division-by-zero-error
251 (inst beq divisor error)
254 (inst div dividend divisor)
260 (define-assembly-routine (signed-truncate
261 (:note "(signed-byte 32) truncate")
264 (:translate truncate)
265 (:arg-types signed-num signed-num)
266 (:result-types signed-num signed-num))
268 ((:arg dividend signed-reg nl0-offset)
269 (:arg divisor signed-reg nl1-offset)
271 (:res quo signed-reg nl2-offset)
272 (:res rem signed-reg nl3-offset))
273 (let ((error (generate-error-code nil division-by-zero-error
275 (inst beq divisor error)
278 (inst div dividend divisor)
284 ;;;; Comparison routines.
287 ((define-cond-assem-rtn (name translate static-fn cmp not-p)
288 `(define-assembly-routine (,name
290 (:return-style :full-call)
292 (:translate ,translate)
294 ((:arg x (descriptor-reg any-reg) a0-offset)
295 (:arg y (descriptor-reg any-reg) a1-offset)
297 (:res res descriptor-reg a0-offset)
299 (:temp temp non-descriptor-reg nl0-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 beq temp DO-COMPARE)
309 (inst lw lip null-tn (static-fun-offset ',static-fn))
310 (inst li nargs (fixnumize 2))
313 (move cfp-tn csp-tn t)
316 (inst ,(if not-p 'beq 'bne) temp DONE)
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 lip interior-reg lip-offset)
341 (:temp nargs any-reg nargs-offset)
342 (:temp ocfp any-reg ocfp-offset))
343 (inst beq x y RETURN-T)
345 (inst and temp fixnum-tag-mask)
346 (inst beq temp RETURN)
350 (inst lw lip null-tn (static-fun-offset 'eql))
351 (inst li nargs (fixnumize 2))
354 (move cfp-tn csp-tn t)
366 (define-assembly-routine (generic-=
368 (:return-style :full-call)
372 ((:arg x (descriptor-reg any-reg) a0-offset)
373 (:arg y (descriptor-reg any-reg) a1-offset)
375 (:res res descriptor-reg a0-offset)
377 (:temp temp non-descriptor-reg nl0-offset)
378 (:temp lip interior-reg lip-offset)
379 (:temp nargs any-reg nargs-offset)
380 (:temp ocfp any-reg ocfp-offset))
382 (inst and temp fixnum-tag-mask)
383 (inst beq temp RETURN)
387 (inst lw lip null-tn (static-fun-offset 'two-arg-=))
388 (inst li nargs (fixnumize 2))
391 (move cfp-tn csp-tn t)
401 (define-assembly-routine (generic-/=
403 (:return-style :full-call)
407 ((:arg x (descriptor-reg any-reg) a0-offset)
408 (:arg y (descriptor-reg any-reg) a1-offset)
410 (:res res descriptor-reg a0-offset)
412 (:temp temp non-descriptor-reg nl0-offset)
413 (:temp lip interior-reg lip-offset)
414 (:temp nargs any-reg nargs-offset)
415 (:temp ocfp any-reg ocfp-offset))
417 (inst and temp fixnum-tag-mask)
418 (inst beq temp RETURN)
422 (inst lw lip null-tn (static-fun-offset 'two-arg-/=))
423 (inst li nargs (fixnumize 2))
426 (move cfp-tn csp-tn t)