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
16 (:return-style :full-call)
20 ((:arg x (descriptor-reg any-reg) a0-offset)
21 (:arg y (descriptor-reg any-reg) a1-offset)
23 (:res res (descriptor-reg any-reg) a0-offset)
25 (:temp temp non-descriptor-reg nl0-offset)
26 (:temp temp2 non-descriptor-reg nl1-offset)
27 (:temp flag non-descriptor-reg nl3-offset)
28 (:temp lra descriptor-reg lra-offset)
29 (:temp nargs any-reg nargs-offset)
30 (:temp lip interior-reg lip-offset)
31 (:temp ocfp any-reg ocfp-offset))
33 ; Clear the damned "sticky overflow" bit in :cr0 and :xer
36 (inst andi. temp temp 3)
37 (inst bne DO-STATIC-FUN)
42 (inst srawi temp2 y 2)
43 (inst add temp2 temp2 temp)
44 (with-fixed-allocation (res flag temp bignum-widetag (1+ bignum-digits-offset))
45 (storew temp2 res bignum-digits-offset other-pointer-lowtag))
46 (lisp-return lra lip :offset 2)
49 (inst lwz lip null-tn (static-fun-offset 'two-arg-+) )
50 (inst li nargs (fixnumize 2))
52 (inst mr cfp-tn csp-tn)
59 (define-assembly-routine
62 (:return-style :full-call)
66 ((:arg x (descriptor-reg any-reg) a0-offset)
67 (:arg y (descriptor-reg any-reg) a1-offset)
69 (:res res (descriptor-reg any-reg) a0-offset)
71 (:temp temp non-descriptor-reg nl0-offset)
72 (:temp temp2 non-descriptor-reg nl1-offset)
73 (:temp flag non-descriptor-reg nl3-offset)
74 (:temp lip interior-reg lip-offset)
75 (:temp lra descriptor-reg lra-offset)
76 (:temp nargs any-reg nargs-offset)
77 (:temp ocfp any-reg ocfp-offset))
79 ; Clear the damned "sticky overflow" bit in :cr0
83 (inst andi. temp temp 3)
84 (inst bne DO-STATIC-FUN)
90 (inst srawi temp2 y 2)
91 (inst sub temp2 temp temp2)
92 (with-fixed-allocation (res flag temp bignum-widetag (1+ bignum-digits-offset))
93 (storew temp2 res bignum-digits-offset other-pointer-lowtag))
94 (lisp-return lra lip :offset 2)
97 (inst lwz lip null-tn (static-fun-offset 'two-arg--))
98 (inst li nargs (fixnumize 2))
100 (inst mr cfp-tn csp-tn)
111 (define-assembly-routine
114 (:return-style :full-call)
118 ((:arg x (descriptor-reg any-reg) a0-offset)
119 (:arg y (descriptor-reg any-reg) a1-offset)
121 (:res res (descriptor-reg any-reg) a0-offset)
123 (:temp temp non-descriptor-reg nl0-offset)
124 (:temp lo non-descriptor-reg nl1-offset)
125 (:temp hi non-descriptor-reg nl2-offset)
126 (:temp pa-flag non-descriptor-reg nl3-offset)
127 (:temp lip interior-reg lip-offset)
128 (:temp lra descriptor-reg lra-offset)
129 (:temp nargs any-reg nargs-offset)
130 (:temp ocfp any-reg ocfp-offset))
132 ;; If either arg is not a fixnum, call the static function. But first ...
136 (inst andi. temp temp 3)
137 ;; Remove the tag from both args, so I don't get so confused.
138 (inst srawi temp x 2)
139 (inst srawi nargs y 2)
140 (inst bne DO-STATIC-FUN)
143 (inst mullwo. lo nargs temp)
144 (inst srawi hi lo 31) ; hi = 32 copies of lo's sign bit
145 (inst bns ONE-WORD-ANSWER)
146 (inst mulhw hi nargs temp)
149 ONE-WORD-ANSWER ; We know that all of the overflow bits are clear.
150 (inst addo temp lo lo)
151 (inst addo. res temp temp)
155 ;; Allocate a BIGNUM for the result.
156 (pseudo-atomic (pa-flag :extra (pad-data-block (1+ bignum-digits-offset)))
157 (let ((one-word (gen-label)))
158 (inst ori res alloc-tn other-pointer-lowtag)
159 ;; We start out assuming that we need one word. Is that correct?
160 (inst srawi temp lo 31)
161 (inst xor. temp temp hi)
162 (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
164 ;; Nope, we need two, so allocate the additional space.
165 (inst addi alloc-tn alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset))
166 (pad-data-block (1+ bignum-digits-offset))))
167 (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
168 (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
169 (emit-label one-word)
170 (storew temp res 0 other-pointer-lowtag)
171 (storew lo res bignum-digits-offset other-pointer-lowtag)))
174 (lisp-return lra lip :offset 2)
177 (inst lwz lip null-tn (static-fun-offset 'two-arg-*))
178 (inst li nargs (fixnumize 2))
179 (inst mr ocfp cfp-tn)
180 (inst mr cfp-tn csp-tn)
187 ((frob (name note cost type sc)
188 `(define-assembly-routine (,name
193 (:arg-types ,type ,type)
194 (:result-types ,type))
195 ((:arg x ,sc nl0-offset)
196 (:arg y ,sc nl1-offset)
197 (:res res ,sc nl0-offset))
198 ,@(when (eq type 'tagged-num)
199 `((inst srawi x x 2)))
200 (inst mullw res x y))))
201 (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg)
202 (frob signed-* "signed *" 41 signed-num signed-reg)
203 (frob fixnum-* "fixnum *" 30 tagged-num any-reg))
210 (define-assembly-routine (positive-fixnum-truncate
211 (:note "unsigned fixnum truncate")
213 (:translate truncate)
215 (:arg-types positive-fixnum positive-fixnum)
216 (:result-types positive-fixnum positive-fixnum))
217 ((:arg dividend any-reg nl0-offset)
218 (:arg divisor any-reg nl1-offset)
220 (:res quo any-reg nl2-offset)
221 (:res rem any-reg nl0-offset))
222 (aver (location= rem dividend))
223 (let ((error (generate-error-code nil division-by-zero-error
225 (inst cmpwi divisor 0)
227 (inst divwu quo dividend divisor)
228 (inst mullw divisor quo divisor)
229 (inst sub rem dividend divisor)
230 (inst slwi quo quo 2))
234 (define-assembly-routine (fixnum-truncate
235 (:note "fixnum truncate")
238 (:translate truncate)
239 (:arg-types tagged-num tagged-num)
240 (:result-types tagged-num tagged-num))
241 ((:arg dividend any-reg nl0-offset)
242 (:arg divisor any-reg nl1-offset)
244 (:res quo any-reg nl2-offset)
245 (:res rem any-reg nl0-offset))
247 (aver (location= rem dividend))
248 (let ((error (generate-error-code nil division-by-zero-error
250 (inst cmpwi divisor 0)
253 (inst divw quo dividend divisor)
254 (inst mullw divisor quo divisor)
255 (inst subf rem divisor dividend)
256 (inst slwi quo quo 2))
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 nl0-offset))
273 (let ((error (generate-error-code nil division-by-zero-error
275 (inst cmpwi divisor 0)
278 (inst divw quo dividend divisor)
279 (inst mullw divisor quo divisor)
280 (inst subf rem divisor dividend))
286 ((define-cond-assem-rtn (name translate static-fn cmp)
287 `(define-assembly-routine
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 lip interior-reg lip-offset)
300 (:temp nargs any-reg nargs-offset)
301 (:temp ocfp any-reg ocfp-offset))
304 (inst andi. nargs nargs 3)
306 (inst beq DO-COMPARE)
309 (inst lwz lip null-tn (static-fun-offset ',static-fn))
310 (inst li nargs (fixnumize 2))
311 (inst mr ocfp cfp-tn)
312 (inst mr cfp-tn csp-tn)
317 (inst b? :cr1 ,cmp done)
318 (inst mr res null-tn)
321 (define-cond-assem-rtn generic-< < two-arg-< :lt)
322 (define-cond-assem-rtn generic-<= <= two-arg-<= :le)
323 (define-cond-assem-rtn generic-> > two-arg-> :gt)
324 (define-cond-assem-rtn generic->= >= two-arg->= :ge))
327 (define-assembly-routine (generic-eql
329 (:return-style :full-call)
333 ((:arg x (descriptor-reg any-reg) a0-offset)
334 (:arg y (descriptor-reg any-reg) a1-offset)
336 (:res res descriptor-reg a0-offset)
338 (:temp lra descriptor-reg lra-offset)
339 (:temp lip interior-reg lip-offset)
340 (:temp nargs any-reg nargs-offset)
341 (:temp ocfp any-reg ocfp-offset))
343 (inst andi. nargs x 3)
344 (inst beq :cr1 RETURN-T)
345 (inst beq RETURN-NIL) ; x was fixnum, not eq y
346 (inst andi. nargs y 3)
347 (inst bne DO-STATIC-FN)
350 (inst mr res null-tn)
351 (lisp-return lra lip :offset 2)
354 (inst lwz lip null-tn (static-fun-offset 'eql))
355 (inst li nargs (fixnumize 2))
356 (inst mr ocfp cfp-tn)
357 (inst mr cfp-tn csp-tn)
363 (define-assembly-routine
366 (:return-style :full-call)
370 ((:arg x (descriptor-reg any-reg) a0-offset)
371 (:arg y (descriptor-reg any-reg) a1-offset)
373 (:res res descriptor-reg a0-offset)
375 (:temp lip interior-reg lip-offset)
376 (:temp lra descriptor-reg lra-offset)
377 (:temp nargs any-reg nargs-offset)
378 (:temp ocfp any-reg ocfp-offset))
381 (inst andi. nargs nargs 3)
383 (inst bne DO-STATIC-FN)
384 (inst beq :cr1 RETURN-T)
386 (inst mr res null-tn)
387 (lisp-return lra lip :offset 2)
390 (inst lwz lip null-tn (static-fun-offset 'two-arg-=))
391 (inst li nargs (fixnumize 2))
392 (inst mr ocfp cfp-tn)
393 (inst mr cfp-tn csp-tn)
399 (define-assembly-routine (generic-/=
401 (:return-style :full-call)
405 ((:arg x (descriptor-reg any-reg) a0-offset)
406 (:arg y (descriptor-reg any-reg) a1-offset)
408 (:res res descriptor-reg a0-offset)
410 (:temp lra descriptor-reg lra-offset)
411 (:temp lip interior-reg lip-offset)
413 (:temp nargs any-reg nargs-offset)
414 (:temp ocfp any-reg ocfp-offset))
416 (inst andi. nargs nargs 3)
418 (inst bne DO-STATIC-FN)
419 (inst beq :cr1 RETURN-NIL)
422 (lisp-return lra lip :offset 2)
425 (inst lwz lip null-tn (static-fun-offset 'two-arg-/=))
426 (inst li nargs (fixnumize 2))
427 (inst mr ocfp cfp-tn)
429 (inst mr cfp-tn csp-tn)
432 (inst mr res null-tn))