1 ;;; **********************************************************************
2 ;;; This code was written as part of the CMU Common Lisp project at
3 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;; **********************************************************************
8 ;;; Stuff to handle simple cases for generic arithmetic.
10 ;;; Written by William Lott.
11 ;;; Conversion by Sean Hallgren
18 (define-assembly-routine (generic-+
20 (:return-style :full-call)
24 ((:arg x (descriptor-reg any-reg) a0-offset)
25 (:arg y (descriptor-reg any-reg) a1-offset)
27 (:res res (descriptor-reg any-reg) a0-offset)
29 (:temp temp non-descriptor-reg nl0-offset)
30 (:temp temp2 non-descriptor-reg nl1-offset)
31 (:temp temp3 non-descriptor-reg nl2-offset)
32 (:temp lip interior-reg lip-offset)
33 (:temp lra descriptor-reg lra-offset)
34 (:temp nargs any-reg nargs-offset)
35 (:temp ocfp any-reg ocfp-offset))
37 (inst bne temp DO-STATIC-FUN)
39 (inst bne temp DO-STATIC-FUN)
42 ; Check to see if we need a bignum
43 (inst sra res 31 temp)
47 (inst sra res 2 temp3)
49 ; From move-from-signed
51 (inst sra temp3 31 temp)
52 (inst cmoveq temp 1 temp2)
54 (inst cmoveq temp 1 temp2)
55 (inst sll temp2 type-bits temp2)
56 (inst bis temp2 bignum-type temp2)
58 (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))
59 (inst bis alloc-tn other-pointer-type res)
60 (storew temp2 res 0 other-pointer-type)
61 (storew temp3 res bignum-digits-offset other-pointer-type)
62 (inst srl temp3 32 temp)
63 (storew temp res (1+ bignum-digits-offset) other-pointer-type))
65 (lisp-return lra lip :offset 2)
68 (inst ldl lip (static-function-offset 'two-arg-+) null-tn)
69 (inst li (fixnumize 2) nargs)
70 (inst move cfp-tn ocfp)
71 (inst move csp-tn cfp-tn)
72 (inst jmp zero-tn lip))
75 (define-assembly-routine (generic--
77 (:return-style :full-call)
81 ((:arg x (descriptor-reg any-reg) a0-offset)
82 (:arg y (descriptor-reg any-reg) a1-offset)
84 (:res res (descriptor-reg any-reg) a0-offset)
86 (:temp temp non-descriptor-reg nl0-offset)
87 (:temp temp2 non-descriptor-reg nl1-offset)
88 (:temp temp3 non-descriptor-reg nl2-offset)
89 (:temp lip interior-reg lip-offset)
90 (:temp lra descriptor-reg lra-offset)
91 (:temp nargs any-reg nargs-offset)
92 (:temp ocfp any-reg ocfp-offset))
94 (inst bne temp DO-STATIC-FUN)
96 (inst bne temp DO-STATIC-FUN)
99 ; Check to see if we need a bignum
100 (inst sra res 31 temp)
104 (inst sra res 2 temp3)
106 ; From move-from-signed
108 (inst sra temp3 31 temp)
109 (inst cmoveq temp 1 temp2)
111 (inst cmoveq temp 1 temp2)
112 (inst sll temp2 type-bits temp2)
113 (inst bis temp2 bignum-type temp2)
115 (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 3)))
116 (inst bis alloc-tn other-pointer-type res)
117 (storew temp2 res 0 other-pointer-type)
118 (storew temp3 res bignum-digits-offset other-pointer-type)
119 (inst srl temp3 32 temp)
120 (storew temp res (1+ bignum-digits-offset) other-pointer-type))
122 (lisp-return lra lip :offset 2)
125 (inst ldl lip (static-function-offset 'two-arg--) null-tn)
126 (inst li (fixnumize 2) nargs)
127 (inst move cfp-tn ocfp)
128 (inst move csp-tn cfp-tn)
129 (inst jmp zero-tn lip))
132 (define-assembly-routine (generic-*
134 (:return-style :full-call)
138 ((:arg x (descriptor-reg any-reg) a0-offset)
139 (:arg y (descriptor-reg any-reg) a1-offset)
141 (:res res (descriptor-reg any-reg) a0-offset)
143 (:temp temp non-descriptor-reg nl0-offset)
144 (:temp lo non-descriptor-reg nl1-offset)
145 (:temp hi non-descriptor-reg nl2-offset)
146 (:temp temp2 non-descriptor-reg nl3-offset)
147 (:temp lip interior-reg lip-offset)
148 (:temp lra descriptor-reg lra-offset)
149 (:temp nargs any-reg nargs-offset)
150 (:temp ocfp any-reg ocfp-offset))
151 ;; If either arg is not a fixnum, call the static function.
153 (inst bne temp DO-STATIC-FUN)
155 (inst bne temp DO-STATIC-FUN)
157 ;; Remove the tag from one arg so that the result will have the correct
160 (inst mulq temp y lo)
163 (inst sra res 32 res)
164 ;; Check to see if the result will fit in a fixnum. (I.e. the high word
165 ;; is just 32 copies of the sign bit of the low word).
166 (inst sra res 31 temp)
167 (inst xor hi temp temp)
169 ;; Shift the double word hi:res down two bits into hi:low to get rid of the
174 ;; Do we need one word or two? Assume two.
175 (inst li (logior (ash 2 type-bits) bignum-type) temp2)
176 (inst sra lo 31 temp)
177 (inst xor temp hi temp)
178 (inst bne temp two-words)
180 ;; Only need one word, fix the header.
181 (inst li (logior (ash 1 type-bits) bignum-type) temp2)
182 ;; Allocate one word.
183 (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset)))
184 (inst bis alloc-tn other-pointer-type res)
185 (storew temp2 res 0 other-pointer-type))
187 (storew lo res bignum-digits-offset other-pointer-type)
189 (lisp-return lra lip :offset 2)
192 ;; Allocate two words.
193 (pseudo-atomic (:extra (pad-data-block (+ 2 bignum-digits-offset)))
194 (inst bis alloc-tn other-pointer-type res)
195 (storew temp2 res 0 other-pointer-type))
197 (storew lo res bignum-digits-offset other-pointer-type)
198 (storew hi res (1+ bignum-digits-offset) other-pointer-type)
200 (lisp-return lra lip :offset 2)
203 (inst ldl lip (static-function-offset 'two-arg-*) null-tn)
204 (inst li (fixnumize 2) nargs)
205 (inst move cfp-tn ocfp)
206 (inst move csp-tn cfp-tn)
207 (inst jmp zero-tn lip)
214 (define-assembly-routine (signed-truncate
215 (:note "(signed-byte 32) truncate")
218 (:translate truncate)
219 (:arg-types signed-num signed-num)
220 (:result-types signed-num signed-num))
222 ((:arg dividend signed-reg nl0-offset)
223 (:arg divisor signed-reg nl1-offset)
225 (:res quo signed-reg nl2-offset)
226 (:res rem signed-reg nl3-offset)
228 (:temp quo-sign signed-reg nl5-offset)
229 (:temp rem-sign signed-reg nargs-offset)
230 (:temp temp1 non-descriptor-reg nl4-offset))
232 (let ((error (generate-error-code nil division-by-zero-error
234 (inst beq divisor error))
236 (inst xor dividend divisor quo-sign)
237 (inst move dividend rem-sign)
238 (let ((label (gen-label)))
239 (inst bge dividend label)
240 (inst subq zero-tn dividend dividend)
242 (let ((label (gen-label)))
243 (inst bge divisor label)
244 (inst subq zero-tn divisor divisor)
246 (inst move zero-tn rem)
247 (inst move zero-tn quo)
248 (inst sll dividend 32 dividend)
251 (inst srl dividend 63 temp1)
253 (inst bis temp1 rem rem)
254 (inst cmple divisor rem temp1)
256 (inst bis temp1 quo quo)
257 (inst sll dividend 1 dividend)
258 (inst subq temp1 1 temp1)
259 (inst zap divisor temp1 temp1)
260 (inst subq rem temp1 rem))
262 (let ((label (gen-label)))
263 ;; If the quo-sign is negative, we need to negate quo.
264 (inst bge quo-sign label)
265 (inst subq zero-tn quo quo)
267 (let ((label (gen-label)))
268 ;; If the rem-sign is negative, we need to negate rem.
269 (inst bge rem-sign label)
270 (inst subq zero-tn rem rem)
274 ;;;; Comparison routines.
277 ((define-cond-assem-rtn (name translate static-fn cmp not-p)
278 `(define-assembly-routine (,name
280 (:return-style :full-call)
282 (:translate ,translate)
284 ((:arg x (descriptor-reg any-reg) a0-offset)
285 (:arg y (descriptor-reg any-reg) a1-offset)
287 (:res res descriptor-reg a0-offset)
289 (:temp temp non-descriptor-reg nl0-offset)
290 (:temp lip interior-reg lip-offset)
291 (:temp nargs any-reg nargs-offset)
292 (:temp ocfp any-reg ocfp-offset))
294 (inst bne temp DO-STATIC-FN)
296 (inst beq temp DO-COMPARE)
299 (inst ldl lip (static-function-offset ',static-fn) null-tn)
300 (inst li (fixnumize 2) nargs)
301 (inst move cfp-tn ocfp)
302 (inst move csp-tn cfp-tn)
303 (inst jmp zero-tn lip)
307 (inst move null-tn res)
308 (inst ,(if not-p 'bne 'beq) temp done)
312 (define-cond-assem-rtn generic-< < two-arg-< (inst cmplt x y temp) nil)
313 (define-cond-assem-rtn generic-> > two-arg-> (inst cmplt y x temp) nil))
316 (define-assembly-routine (generic-eql
318 (:return-style :full-call)
322 ((:arg x (descriptor-reg any-reg) a0-offset)
323 (:arg y (descriptor-reg any-reg) a1-offset)
325 (:res res descriptor-reg a0-offset)
327 (:temp temp non-descriptor-reg nl0-offset)
328 (:temp lip interior-reg lip-offset)
329 (:temp lra descriptor-reg lra-offset)
330 (:temp nargs any-reg nargs-offset)
331 (:temp ocfp any-reg ocfp-offset))
332 (inst cmpeq x y temp)
333 (inst bne temp RETURN-T)
335 (inst beq temp RETURN-NIL)
337 (inst bne temp DO-STATIC-FN)
340 (inst move null-tn res)
341 (lisp-return lra lip :offset 2)
344 (inst ldl lip (static-function-offset 'eql) null-tn)
345 (inst li (fixnumize 2) nargs)
346 (inst move cfp-tn ocfp)
347 (inst move csp-tn cfp-tn)
348 (inst jmp zero-tn lip)
353 (define-assembly-routine (generic-=
355 (:return-style :full-call)
359 ((:arg x (descriptor-reg any-reg) a0-offset)
360 (:arg y (descriptor-reg any-reg) a1-offset)
362 (:res res descriptor-reg a0-offset)
364 (:temp temp non-descriptor-reg nl0-offset)
365 (:temp lip interior-reg lip-offset)
366 (:temp lra descriptor-reg lra-offset)
367 (:temp nargs any-reg nargs-offset)
368 (:temp ocfp any-reg ocfp-offset))
370 (inst bne temp DO-STATIC-FN)
372 (inst bne temp DO-STATIC-FN)
373 (inst cmpeq x y temp)
374 (inst bne temp RETURN-T)
376 (inst move null-tn res)
377 (lisp-return lra lip :offset 2)
380 (inst ldl lip (static-function-offset 'two-arg-=) null-tn)
381 (inst li (fixnumize 2) nargs)
382 (inst move cfp-tn ocfp)
383 (inst move csp-tn cfp-tn)
384 (inst jmp zero-tn lip)
389 (define-assembly-routine (generic-/=
391 (:return-style :full-call)
395 ((:arg x (descriptor-reg any-reg) a0-offset)
396 (:arg y (descriptor-reg any-reg) a1-offset)
398 (:res res descriptor-reg a0-offset)
400 (:temp temp non-descriptor-reg nl0-offset)
401 (:temp lip interior-reg lip-offset)
402 (:temp lra descriptor-reg lra-offset)
403 (:temp nargs any-reg nargs-offset)
404 (:temp ocfp any-reg ocfp-offset))
406 (inst bne temp DO-STATIC-FN)
408 (inst bne temp DO-STATIC-FN)
409 (inst cmpeq x y temp)
410 (inst bne temp RETURN-NIL)
413 (lisp-return lra lip :offset 2)
416 (inst ldl lip (static-function-offset 'two-arg-=) null-tn)
417 (inst li (fixnumize 2) nargs)
418 (inst move cfp-tn ocfp)
419 (inst move csp-tn cfp-tn)
420 (inst jmp zero-tn lip)
423 (inst move null-tn res))