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-
* "unsigned *" 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
))