Don't go through fdefn when referencing #'known-functions.
[sbcl.git] / src / assembly / mips / arith.lisp
1 ;;;; stuff to handle simple cases for generic arithmetic
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!VM")
13
14
15 \f
16 ;;;; Addition and subtraction.
17
18 ;;; static-fun-offset returns the address of the raw_addr slot of
19 ;;; a static function's fdefn.
20
21 ;;; Note that there is only one use of static-fun-offset outside this
22 ;;; file (in genesis.lisp)
23
24 (define-assembly-routine (generic-+
25                           (:cost 10)
26                           (:return-style :full-call)
27                           (:translate +)
28                           (:policy :safe)
29                           (:save-p t))
30                          ((:arg x (descriptor-reg any-reg) a0-offset)
31                           (:arg y (descriptor-reg any-reg) a1-offset)
32
33                           (:res res (descriptor-reg any-reg) a0-offset)
34
35                           (:temp temp non-descriptor-reg nl0-offset)
36                           (:temp temp1 non-descriptor-reg nl1-offset)
37                           (:temp temp2 non-descriptor-reg nl2-offset)
38                           (:temp pa-flag non-descriptor-reg nl4-offset)
39                           (:temp lra descriptor-reg lra-offset)
40                           (:temp lip interior-reg lip-offset)
41                           (:temp nargs any-reg nargs-offset)
42                           (:temp ocfp any-reg ocfp-offset))
43   (inst or temp x y)
44   (inst and temp fixnum-tag-mask)
45   (inst bne temp DO-STATIC-FUN)
46   (inst addu temp x y)
47   ;; check for overflow
48   (inst xor temp1 temp x)
49   (inst xor temp2 temp y)
50   (inst and temp1 temp2)
51   (inst bltz temp1 DO-OVERFLOW)
52   (inst sra temp1 x n-fixnum-tag-bits)
53   (inst move res temp)
54   (lisp-return lra lip :offset 2)
55
56   DO-OVERFLOW
57   ;; We did overflow, so do the bignum version
58   (inst sra temp2 y n-fixnum-tag-bits)
59   (inst addu temp temp1 temp2)
60   (with-fixed-allocation (res pa-flag temp2 bignum-widetag
61                           (1+ bignum-digits-offset) nil)
62     (storew temp res bignum-digits-offset other-pointer-lowtag))
63   (lisp-return lra lip :offset 2)
64
65   DO-STATIC-FUN
66   (inst lw lip null-tn (static-fun-offset 'two-arg-+))
67   (inst li nargs (fixnumize 2))
68   (move ocfp cfp-tn)
69   (inst j lip)
70   (move cfp-tn csp-tn t))
71
72
73 (define-assembly-routine (generic--
74                           (:cost 10)
75                           (:return-style :full-call)
76                           (:translate -)
77                           (:policy :safe)
78                           (:save-p t))
79                          ((:arg x (descriptor-reg any-reg) a0-offset)
80                           (:arg y (descriptor-reg any-reg) a1-offset)
81
82                           (:res res (descriptor-reg any-reg) a0-offset)
83
84                           (:temp temp non-descriptor-reg nl0-offset)
85                           (:temp temp1 non-descriptor-reg nl1-offset)
86                           (:temp temp2 non-descriptor-reg nl2-offset)
87                           (:temp pa-flag non-descriptor-reg nl4-offset)
88                           (:temp lra descriptor-reg lra-offset)
89                           (:temp lip interior-reg lip-offset)
90                           (:temp nargs any-reg nargs-offset)
91                           (:temp ocfp any-reg ocfp-offset))
92   (inst or temp x y)
93   (inst and temp fixnum-tag-mask)
94   (inst bne temp DO-STATIC-FUN)
95   (inst subu temp x y)
96   ;; check for overflow
97   (inst xor temp1 x y)
98   (inst xor temp2 x temp)
99   (inst and temp1 temp2)
100   (inst bltz temp1 DO-OVERFLOW)
101   (inst sra temp1 x n-fixnum-tag-bits)
102   (inst move res temp)
103   (lisp-return lra lip :offset 2)
104
105   DO-OVERFLOW
106   ;; We did overflow, so do the bignum version
107   (inst sra temp2 y n-fixnum-tag-bits)
108   (inst subu temp temp1 temp2)
109   (with-fixed-allocation (res pa-flag temp2 bignum-widetag
110                           (1+ bignum-digits-offset) nil)
111     (storew temp res bignum-digits-offset other-pointer-lowtag))
112   (lisp-return lra lip :offset 2)
113
114   DO-STATIC-FUN
115   (inst lw lip null-tn (static-fun-offset 'two-arg--))
116   (inst li nargs (fixnumize 2))
117   (move ocfp cfp-tn)
118   (inst j lip)
119   (move cfp-tn csp-tn t))
120
121
122 \f
123 ;;;; Multiplication
124
125
126 (define-assembly-routine (generic-*
127                           (:cost 25)
128                           (:return-style :full-call)
129                           (:translate *)
130                           (:policy :safe)
131                           (:save-p t))
132                          ((:arg x (descriptor-reg any-reg) a0-offset)
133                           (:arg y (descriptor-reg any-reg) a1-offset)
134
135                           (:res res (descriptor-reg any-reg) a0-offset)
136
137                           (:temp temp non-descriptor-reg nl0-offset)
138                           (:temp lo non-descriptor-reg nl1-offset)
139                           (:temp hi non-descriptor-reg nl2-offset)
140                           (:temp pa-flag non-descriptor-reg nl4-offset)
141                           (:temp lra descriptor-reg lra-offset)
142                           (:temp lip interior-reg lip-offset)
143                           (:temp nargs any-reg nargs-offset)
144                           (:temp ocfp any-reg ocfp-offset))
145   ;; If either arg is not a fixnum, call the static function.
146   (inst or temp x y)
147   (inst and temp fixnum-tag-mask)
148   (inst bne temp DO-STATIC-FUN)
149   ;; Remove the tag from one arg so that the result will have the correct
150   ;; fixnum tag.
151   (inst sra temp x n-fixnum-tag-bits)
152   (inst mult temp y)
153   (inst mflo res)
154   (inst mfhi hi)
155   ;; Check to see if the result will fit in a fixnum.  (I.e. the high word
156   ;; is just 32 copies of the sign bit of the low word).
157   (inst sra temp res 31)
158   (inst bne temp hi DO-BIGNUM)
159   (inst srl lo res n-fixnum-tag-bits)
160   (lisp-return lra lip :offset 2)
161
162   DO-BIGNUM
163   ;; Shift the double word hi:res down two bits into hi:low to get rid of the
164   ;; fixnum tag.
165   (inst sll temp hi (- n-word-bits n-fixnum-tag-bits))
166   (inst or lo temp)
167   (inst sra hi n-fixnum-tag-bits)
168
169   ;; Do we need one word or two?  Assume two.
170   (inst sra temp lo 31)
171   (inst bne temp hi TWO-WORDS)
172   ;; Assume a two word header.
173   (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
174
175   ;; Only need one word, fix the header.
176   (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
177
178   (pseudo-atomic (pa-flag :extra (pad-data-block (+ 1 bignum-digits-offset)))
179     (inst or res alloc-tn other-pointer-lowtag)
180     (storew temp res 0 other-pointer-lowtag))
181   (storew lo res bignum-digits-offset other-pointer-lowtag)
182   (lisp-return lra lip :offset 2)
183
184   TWO-WORDS
185   (pseudo-atomic (pa-flag :extra (pad-data-block (+ 2 bignum-digits-offset)))
186     (inst or res alloc-tn other-pointer-lowtag)
187     (storew temp res 0 other-pointer-lowtag))
188
189   (storew lo res bignum-digits-offset other-pointer-lowtag)
190   (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
191   (lisp-return lra lip :offset 2)
192
193   DO-STATIC-FUN
194   (inst lw lip null-tn (static-fun-offset 'two-arg-*))
195   (inst li nargs (fixnumize 2))
196   (move ocfp cfp-tn)
197   (inst j lip)
198   (move cfp-tn csp-tn t))
199
200
201 (macrolet
202     ((frob (name note cost type sc signed-p)
203        `(define-assembly-routine (,name
204                                   (:note ,note)
205                                   (:cost ,cost)
206                                   (:translate *)
207                                   (:policy :fast-safe)
208                                   (:arg-types ,type ,type)
209                                   (:result-types ,type))
210                                  ((:arg x ,sc nl0-offset)
211                                   (:arg y ,sc nl1-offset)
212                                   (:res res ,sc nl0-offset))
213           ,@(when (eq type 'tagged-num)
214               `((inst sra x 2)))
215           (inst ,(if signed-p 'mult 'multu) x y)
216           (inst mflo res))))
217   (frob unsigned-* "unsigned *" 40 unsigned-num unsigned-reg nil)
218   (frob signed-* "signed *" 41 signed-num signed-reg t)
219   (frob fixnum-* "fixnum *" 30 tagged-num any-reg t))
220
221
222 \f
223 ;;;; Division.
224
225
226 (define-assembly-routine (positive-fixnum-truncate
227                           (:note "unsigned fixnum truncate")
228                           (:cost 45)
229                           (:translate truncate)
230                           (:policy :fast-safe)
231                           (:arg-types positive-fixnum positive-fixnum)
232                           (:result-types positive-fixnum positive-fixnum))
233                          ((:arg dividend any-reg nl0-offset)
234                           (:arg divisor any-reg nl1-offset)
235
236                           (:res quo any-reg nl2-offset)
237                           (:res rem any-reg nl3-offset))
238   (let ((error (generate-error-code nil division-by-zero-error
239                                     dividend divisor)))
240     (inst beq divisor error)
241     (inst nop))
242
243     (inst divu dividend divisor)
244     (inst mflo quo)
245     (inst mfhi rem)
246     (inst sll quo 2))
247
248
249 (define-assembly-routine (fixnum-truncate
250                           (:note "fixnum truncate")
251                           (:cost 50)
252                           (:policy :fast-safe)
253                           (:translate truncate)
254                           (:arg-types tagged-num tagged-num)
255                           (:result-types tagged-num tagged-num))
256                          ((:arg dividend any-reg nl0-offset)
257                           (:arg divisor any-reg nl1-offset)
258
259                           (:res quo any-reg nl2-offset)
260                           (:res rem any-reg nl3-offset))
261   (let ((error (generate-error-code nil division-by-zero-error
262                                     dividend divisor)))
263     (inst beq divisor error)
264     (inst nop))
265
266     (inst div dividend divisor)
267     (inst mflo quo)
268     (inst mfhi rem)
269     (inst sll quo 2))
270
271
272 (define-assembly-routine (signed-truncate
273                           (:note "(signed-byte 32) truncate")
274                           (:cost 60)
275                           (:policy :fast-safe)
276                           (:translate truncate)
277                           (:arg-types signed-num signed-num)
278                           (:result-types signed-num signed-num))
279
280                          ((:arg dividend signed-reg nl0-offset)
281                           (:arg divisor signed-reg nl1-offset)
282
283                           (:res quo signed-reg nl2-offset)
284                           (:res rem signed-reg nl3-offset))
285   (let ((error (generate-error-code nil division-by-zero-error
286                                     dividend divisor)))
287     (inst beq divisor error)
288     (inst nop))
289
290     (inst div dividend divisor)
291     (inst mflo quo)
292     (inst mfhi rem))
293
294
295 \f
296 ;;;; Comparison routines.
297
298 (macrolet
299     ((define-cond-assem-rtn (name translate static-fn cmp not-p)
300        `(define-assembly-routine (,name
301                                   (:cost 10)
302                                   (:return-style :full-call)
303                                   (:policy :safe)
304                                   (:translate ,translate)
305                                   (:save-p t))
306                                  ((:arg x (descriptor-reg any-reg) a0-offset)
307                                   (:arg y (descriptor-reg any-reg) a1-offset)
308
309                                   (:res res descriptor-reg a0-offset)
310
311                                   (:temp temp non-descriptor-reg nl0-offset)
312                                   (:temp lra descriptor-reg lra-offset)
313                                   (:temp lip interior-reg lip-offset)
314                                   (:temp nargs any-reg nargs-offset)
315                                   (:temp ocfp any-reg ocfp-offset))
316           (inst or temp x y)
317           (inst and temp fixnum-tag-mask)
318           (inst bne temp DO-STATIC-FUN)
319           ,cmp
320
321           (inst ,(if not-p 'beq 'bne) temp DONE)
322           (move res null-tn t)
323           (load-symbol res t)
324
325           DONE
326           (lisp-return lra lip :offset 2)
327
328           DO-STATIC-FUN
329           (inst lw lip null-tn (static-fun-offset ',static-fn))
330           (inst li nargs (fixnumize 2))
331           (move ocfp cfp-tn)
332           (inst j lip)
333           (move cfp-tn csp-tn t))))
334
335   (define-cond-assem-rtn generic-< < two-arg-< (inst slt temp x y) t)
336   (define-cond-assem-rtn generic-<= <= two-arg-<= (inst slt temp x y) nil)
337   (define-cond-assem-rtn generic-> > two-arg-> (inst slt temp y x) t)
338   (define-cond-assem-rtn generic->= >= two-arg->= (inst slt temp y x) nil))
339
340
341 (define-assembly-routine (generic-eql
342                           (:cost 10)
343                           (:return-style :full-call)
344                           (:policy :safe)
345                           (:translate eql)
346                           (:save-p t))
347                          ((:arg x (descriptor-reg any-reg) a0-offset)
348                           (:arg y (descriptor-reg any-reg) a1-offset)
349
350                           (:res res descriptor-reg a0-offset)
351
352                           (:temp temp non-descriptor-reg nl0-offset)
353                           (:temp lra descriptor-reg lra-offset)
354                           (:temp lip interior-reg lip-offset)
355                           (:temp nargs any-reg nargs-offset)
356                           (:temp ocfp any-reg ocfp-offset))
357   (inst beq x y RETURN-T)
358   (inst or temp x y)
359   (inst and temp fixnum-tag-mask)
360   (inst bne temp DO-STATIC-FUN)
361   (inst nop)
362
363   (inst bne x y DONE)
364   (move res null-tn t)
365
366   RETURN-T
367   (load-symbol res t)
368
369   DONE
370   (lisp-return lra lip :offset 2)
371
372   DO-STATIC-FUN
373   (inst lw lip null-tn (static-fun-offset 'eql))
374   (inst li nargs (fixnumize 2))
375   (move ocfp cfp-tn)
376   (inst j lip)
377   (move cfp-tn csp-tn t))
378
379
380 (define-assembly-routine (generic-=
381                           (:cost 10)
382                           (:return-style :full-call)
383                           (:policy :safe)
384                           (:translate =)
385                           (:save-p t))
386                          ((:arg x (descriptor-reg any-reg) a0-offset)
387                           (:arg y (descriptor-reg any-reg) a1-offset)
388
389                           (:res res descriptor-reg a0-offset)
390
391                           (:temp temp non-descriptor-reg nl0-offset)
392                           (:temp lra descriptor-reg lra-offset)
393                           (:temp lip interior-reg lip-offset)
394                           (:temp nargs any-reg nargs-offset)
395                           (:temp ocfp any-reg ocfp-offset))
396   (inst or temp x y)
397   (inst and temp fixnum-tag-mask)
398   (inst bne temp DO-STATIC-FUN)
399   (inst nop)
400
401   (inst bne x y DONE)
402   (move res null-tn t)
403   (load-symbol res t)
404
405   DONE
406   (lisp-return lra lip :offset 2)
407
408   DO-STATIC-FUN
409   (inst lw lip null-tn (static-fun-offset 'two-arg-=))
410   (inst li nargs (fixnumize 2))
411   (move ocfp cfp-tn)
412   (inst j lip)
413   (move cfp-tn csp-tn t))
414
415
416 (define-assembly-routine (generic-/=
417                           (:cost 10)
418                           (:return-style :full-call)
419                           (:policy :safe)
420                           (:translate /=)
421                           (:save-p t))
422                          ((:arg x (descriptor-reg any-reg) a0-offset)
423                           (:arg y (descriptor-reg any-reg) a1-offset)
424
425                           (:res res descriptor-reg a0-offset)
426
427                           (:temp temp non-descriptor-reg nl0-offset)
428                           (:temp lra descriptor-reg lra-offset)
429                           (:temp lip interior-reg lip-offset)
430                           (:temp nargs any-reg nargs-offset)
431                           (:temp ocfp any-reg ocfp-offset))
432   (inst or temp x y)
433   (inst and temp fixnum-tag-mask)
434   (inst bne temp DO-STATIC-FUN)
435   (inst nop)
436
437   (inst beq x y DONE)
438   (move res null-tn t)
439   (load-symbol res t)
440
441   DONE
442   (lisp-return lra lip :offset 2)
443
444   DO-STATIC-FUN
445   (inst lw lip null-tn (static-fun-offset 'two-arg-/=))
446   (inst li nargs (fixnumize 2))
447   (move ocfp cfp-tn)
448   (inst j lip)
449   (move cfp-tn csp-tn t))