Make MAKE-LISP-OBJ pickier on CHENEYGC.
[sbcl.git] / src / assembly / hppa / arith.lisp
1 (in-package "SB!VM")
2
3 \f
4 ;;;; Multiplication and Division helping routines.
5
6 ;;; ?? FIXME: Where are generic-* and generic-/?
7 #+sb-assembling
8 (define-assembly-routine
9     multiply
10     ((:arg x (signed-reg) nl0-offset)
11      (:arg y (signed-reg) nl1-offset)
12
13      (:res res (signed-reg) nl2-offset)
14
15      (:temp tmp (unsigned-reg) nl3-offset)
16      (:temp sign (unsigned-reg) nl4-offset))
17
18   ;; Determine the sign of the result.
19   (inst extrs x 0 1 sign :=)
20   (inst sub zero-tn x x)
21   (inst extrs y 0 1 tmp :=)
22   (inst sub zero-tn y y)
23   (inst xor sign tmp sign)
24
25   ;; Make sure X is less then Y.
26   (inst comclr x y tmp :<<)
27   (inst xor x y tmp)
28   (inst xor x tmp x)
29   (inst xor y tmp y)
30   ;; Blow out of here if the result is zero.
31   (inst comb := x zero-tn done)
32   (inst li 0 res)
33
34   LOOP
35   (inst extru x 31 1 zero-tn :ev)
36   (inst add y res res)
37   (inst extru x 30 1 zero-tn :ev)
38   (inst sh1add y res res)
39   (inst extru x 29 1 zero-tn :ev)
40   (inst sh2add y res res)
41   (inst extru x 28 1 zero-tn :ev)
42   (inst sh3add y res res)
43
44   (inst srl x 4 x)
45   (inst comb :<> x zero-tn loop)
46   (inst sll y 4 y)
47
48   DONE
49   (inst xor res sign res)
50   (inst add res sign res))
51
52 (define-assembly-routine
53     (truncate)
54     ((:arg dividend signed-reg nl0-offset)
55      (:arg divisor signed-reg nl1-offset)
56
57      (:res quo signed-reg nl2-offset)
58      (:res rem signed-reg nl3-offset))
59   ;; Move abs(divident) into quo.
60   (inst move dividend quo :>=)
61   (inst sub zero-tn quo quo)
62   ;; Do one divive-step with -divisor to prime V  (use rem as a temp)
63   (inst sub zero-tn divisor rem)
64   (inst ds zero-tn rem zero-tn)
65   ;; Shift the divident/quotient one bit, setting the carry flag.
66   (inst add quo quo quo)
67   ;; The first real divive-step.
68   (inst ds zero-tn divisor rem)
69   (inst addc quo quo quo)
70   ;; And 31 more of them.
71   (dotimes (i 31)
72     (inst ds rem divisor rem)
73     (inst addc quo quo quo))
74   ;; If the remainder is negative, we need to add the absolute value of the
75   ;; divisor.
76   (inst comb :>= rem zero-tn remainder-positive)
77   (inst comclr divisor zero-tn zero-tn :<)
78   (inst add rem divisor rem :tr)
79   (inst sub rem divisor rem)
80   REMAINDER-POSITIVE
81   ;; Now we have to fix the signs of quo and rem.
82   (inst xor divisor dividend zero-tn :>=)
83   (inst sub zero-tn quo quo)
84   (inst move dividend zero-tn :>=)
85   (inst sub zero-tn rem rem))
86
87 \f
88 ;;;; Generic arithmetic.
89
90 (define-assembly-routine (generic-+
91                           (:cost 10)
92                           (:return-style :full-call)
93                           (:translate +)
94                           (:policy :safe)
95                           (:save-p t))
96                          ((:arg x (descriptor-reg any-reg) a0-offset)
97                           (:arg y (descriptor-reg any-reg) a1-offset)
98                           (:res res (descriptor-reg any-reg) a0-offset)
99                           (:temp temp non-descriptor-reg nl0-offset)
100                           (:temp temp1 non-descriptor-reg nl1-offset)
101                           (:temp temp2 non-descriptor-reg nl2-offset)
102                           (:temp lra descriptor-reg lra-offset)
103                           (:temp lip interior-reg lip-offset)
104                           (:temp nargs any-reg nargs-offset)
105                           (:temp ocfp any-reg ocfp-offset))
106   ;; If either arg is not fixnum, use two-arg-+ to summarize
107   (inst or x y temp)
108   (inst extru temp 31 3 zero-tn :=)
109   (inst b DO-STATIC-FUN :nullify t)
110   ;; check for overflow
111   (inst add x y temp)
112   (inst xor temp x temp1)
113   (inst xor temp y temp2)
114   (inst and temp1 temp2 temp1)
115   (inst bc :< nil temp1 zero-tn DO-OVERFLOW)
116   (inst move temp res)
117   (lisp-return lra :offset 1)
118
119   DO-OVERFLOW
120   ;; We did overflow, so do the bignum version
121   (inst sra x n-fixnum-tag-bits temp1)
122   (inst sra y n-fixnum-tag-bits temp2)
123   (inst add temp1 temp2 temp)
124   (with-fixed-allocation (res nil temp2 bignum-widetag
125                           (1+ bignum-digits-offset) nil)
126     (storew temp res bignum-digits-offset other-pointer-lowtag))
127   (lisp-return lra :offset 1)
128
129   DO-STATIC-FUN
130   (inst ldw (static-fun-offset 'two-arg-+) null-tn lip)
131   (inst li (fixnumize 2) nargs)
132   (move cfp-tn ocfp)
133   (inst bv lip)
134   (move csp-tn cfp-tn t))
135
136 (define-assembly-routine (generic--
137                           (:cost 10)
138                           (:return-style :full-call)
139                           (:translate -)
140                           (:policy :safe)
141                           (:save-p t))
142                          ((:arg x (descriptor-reg any-reg) a0-offset)
143                           (:arg y (descriptor-reg any-reg) a1-offset)
144
145                           (:res res (descriptor-reg any-reg) a0-offset)
146
147                           (:temp temp non-descriptor-reg nl0-offset)
148                           (:temp temp1 non-descriptor-reg nl1-offset)
149                           (:temp temp2 non-descriptor-reg nl2-offset)
150                           (:temp lra descriptor-reg lra-offset)
151                           (:temp lip interior-reg lip-offset)
152                           (:temp nargs any-reg nargs-offset)
153                           (:temp ocfp any-reg ocfp-offset))
154   ;; If either arg is not fixnum, use two-arg-+ to summarize
155   (inst or x y temp)
156   (inst extru temp 31 3 zero-tn :=)
157   (inst b DO-STATIC-FUN :nullify t)
158   (inst sub x y temp)
159   ;; check for overflow
160   (inst xor x y temp1)
161   (inst xor x temp temp2)
162   (inst and temp2 temp1 temp1)
163   (inst bc :< nil temp1 zero-tn DO-OVERFLOW)
164   (inst move temp res)
165   (lisp-return lra :offset 1)
166
167   DO-OVERFLOW
168   ;; We did overflow, so do the bignum version
169   (inst sra x n-fixnum-tag-bits temp1)
170   (inst sra y n-fixnum-tag-bits temp2)
171   (inst sub temp1 temp2 temp)
172   (with-fixed-allocation (res nil temp2 bignum-widetag
173                           (1+ bignum-digits-offset) nil)
174     (storew temp res bignum-digits-offset other-pointer-lowtag))
175   (lisp-return lra :offset 1)
176
177   DO-STATIC-FUN
178   (inst ldw (static-fun-offset 'two-arg--) null-tn lip)
179   (inst li (fixnumize 2) nargs)
180   (move cfp-tn ocfp)
181   (inst bv lip)
182   (move csp-tn cfp-tn t))
183
184 \f
185 ;;;; Comparison routines.
186
187 (macrolet
188     ((define-cond-assem-rtn (name translate static-fn cond)
189        `(define-assembly-routine (,name
190                                   (:cost 10)
191                                   (:return-style :full-call)
192                                   (:policy :safe)
193                                   (:translate ,translate)
194                                   (:save-p t))
195                                  ((:arg x (descriptor-reg any-reg) a0-offset)
196                                   (:arg y (descriptor-reg any-reg) a1-offset)
197
198                                   (:res res descriptor-reg a0-offset)
199
200                                   (:temp lip interior-reg lip-offset)
201                                   (:temp lra descriptor-reg lra-offset)
202                                   (:temp nargs any-reg nargs-offset)
203                                   (:temp ocfp any-reg ocfp-offset))
204           (inst extru x 31 2 zero-tn :=)
205           (inst b do-static-fn :nullify t)
206           (inst extru y 31 2 zero-tn :=)
207           (inst b do-static-fn :nullify t)
208
209           (inst comclr x y zero-tn ,cond)
210           (inst move null-tn res :tr)
211           (load-symbol res t)
212           (lisp-return lra :offset 1)
213
214           DO-STATIC-FN
215           (inst ldw (static-fun-offset ',static-fn) null-tn lip)
216           (inst li (fixnumize 2) nargs)
217           (inst move cfp-tn ocfp)
218           (inst bv lip)
219           (inst move csp-tn cfp-tn))))
220
221   (define-cond-assem-rtn generic-< < two-arg-< :<)
222   (define-cond-assem-rtn generic-> > two-arg-> :>))
223
224
225 (define-assembly-routine
226     (generic-eql
227      (:cost 10)
228      (:return-style :full-call)
229      (:policy :safe)
230      (:translate eql)
231      (:save-p t))
232     ((:arg x (descriptor-reg any-reg) a0-offset)
233      (:arg y (descriptor-reg any-reg) a1-offset)
234
235      (:res res descriptor-reg a0-offset)
236
237      (:temp lip interior-reg lip-offset)
238      (:temp lra descriptor-reg lra-offset)
239      (:temp nargs any-reg nargs-offset)
240      (:temp ocfp any-reg ocfp-offset))
241
242   (inst comb := x y return-t :nullify t)
243   (inst extru x 31 2 zero-tn :<>)
244   (inst b return-nil :nullify t)
245   (inst extru y 31 2 zero-tn :=)
246   (inst b do-static-fn :nullify t)
247
248   RETURN-NIL
249   (inst move null-tn res)
250   (lisp-return lra :offset 1)
251
252   DO-STATIC-FN
253   (inst ldw (static-fun-offset 'eql) null-tn lip)
254   (inst li (fixnumize 2) nargs)
255   (inst move cfp-tn ocfp)
256   (inst bv lip)
257   (inst move csp-tn cfp-tn)
258
259   RETURN-T
260   (load-symbol res t))
261
262 (define-assembly-routine
263     (generic-=
264      (:cost 10)
265      (:return-style :full-call)
266      (:policy :safe)
267      (:translate =)
268      (:save-p t))
269     ((:arg x (descriptor-reg any-reg) a0-offset)
270      (:arg y (descriptor-reg any-reg) a1-offset)
271
272      (:res res descriptor-reg a0-offset)
273
274      (:temp lip interior-reg lip-offset)
275      (:temp lra descriptor-reg lra-offset)
276      (:temp nargs any-reg nargs-offset)
277      (:temp ocfp any-reg ocfp-offset))
278
279   (inst comb := x y return-t :nullify t)
280   (inst extru x 31 2 zero-tn :=)
281   (inst b do-static-fn :nullify t)
282   (inst extru y 31 2 zero-tn :=)
283   (inst b do-static-fn :nullify t)
284
285   (inst move null-tn res)
286   (lisp-return lra :offset 1)
287
288   DO-STATIC-FN
289   (inst ldw (static-fun-offset 'two-arg-=) null-tn lip)
290   (inst li (fixnumize 2) nargs)
291   (inst move cfp-tn ocfp)
292   (inst bv lip)
293   (inst move csp-tn cfp-tn)
294
295   RETURN-T
296   (load-symbol res t))