1.0.9.13: copy the WRAPPER-SLOT-TABLE in FORCE-CACHE-FLUSHES
[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
53 #+sb-assembling
54 (define-assembly-routine
55     (truncate)
56     ((:arg dividend signed-reg nl0-offset)
57      (:arg divisor signed-reg nl1-offset)
58
59      (:res quo signed-reg nl2-offset)
60      (:res rem signed-reg nl3-offset))
61
62   ;; Move abs(divident) into quo.
63   (inst move dividend quo :>=)
64   (inst sub zero-tn quo quo)
65   ;; Do one divive-step with -divisor to prime V  (use rem as a temp)
66   (inst sub zero-tn divisor rem)
67   (inst ds zero-tn rem zero-tn)
68   ;; Shift the divident/quotient one bit, setting the carry flag.
69   (inst add quo quo quo)
70   ;; The first real divive-step.
71   (inst ds zero-tn divisor rem)
72   (inst addc quo quo quo)
73   ;; And 31 more of them.
74   (dotimes (i 31)
75     (inst ds rem divisor rem)
76     (inst addc quo quo quo))
77   ;; If the remainder is negative, we need to add the absolute value of the
78   ;; divisor.
79   (inst comb :>= rem zero-tn remainder-positive)
80   (inst comclr divisor zero-tn zero-tn :<)
81   (inst add rem divisor rem :tr)
82   (inst sub rem divisor rem)
83   REMAINDER-POSITIVE
84   ;; Now we have to fix the signs of quo and rem.
85   (inst xor divisor dividend zero-tn :>=)
86   (inst sub zero-tn quo quo)
87   (inst move dividend zero-tn :>=)
88   (inst sub zero-tn rem rem))
89
90
91 \f
92 ;;;; Generic arithmetic.
93
94 (define-assembly-routine (generic-+
95                           (:cost 10)
96                           (:return-style :full-call)
97                           (:translate +)
98                           (:policy :safe)
99                           (:save-p t))
100                          ((:arg x (descriptor-reg any-reg) a0-offset)
101                           (:arg y (descriptor-reg any-reg) a1-offset)
102
103                           (:res res (descriptor-reg any-reg) a0-offset)
104
105                           (:temp lip interior-reg lip-offset)
106                           (:temp lra descriptor-reg lra-offset)
107                           (:temp nargs any-reg nargs-offset)
108                           (:temp ocfp any-reg ocfp-offset))
109   (inst extru x 31 2 zero-tn :=)
110   (inst b do-static-fun :nullify t)
111   (inst extru y 31 2 zero-tn :=)
112   (inst b do-static-fun :nullify t)
113   (inst addo x y res)
114   (lisp-return lra :offset 1)
115
116   DO-STATIC-FUN
117   (inst ldw (static-fun-offset 'two-arg-+) null-tn lip)
118   (inst li (fixnumize 2) nargs)
119   (inst move cfp-tn ocfp)
120   (inst bv lip)
121   (inst move csp-tn cfp-tn))
122
123 (define-assembly-routine (generic--
124                           (:cost 10)
125                           (:return-style :full-call)
126                           (:translate -)
127                           (:policy :safe)
128                           (:save-p t))
129                          ((:arg x (descriptor-reg any-reg) a0-offset)
130                           (:arg y (descriptor-reg any-reg) a1-offset)
131
132                           (:res res (descriptor-reg any-reg) a0-offset)
133
134                           (:temp lip interior-reg lip-offset)
135                           (:temp lra descriptor-reg lra-offset)
136                           (:temp nargs any-reg nargs-offset)
137                           (:temp ocfp any-reg ocfp-offset))
138   (inst extru x 31 2 zero-tn :=)
139   (inst b do-static-fun :nullify t)
140   (inst extru y 31 2 zero-tn :=)
141   (inst b do-static-fun :nullify t)
142   (inst subo x y res)
143   (lisp-return lra :offset 1)
144
145   DO-STATIC-FUN
146   (inst ldw (static-fun-offset 'two-arg--) null-tn lip)
147   (inst li (fixnumize 2) nargs)
148   (inst move cfp-tn ocfp)
149   (inst bv lip)
150   (inst move csp-tn cfp-tn))
151
152
153 \f
154 ;;;; Comparison routines.
155
156 (macrolet
157     ((define-cond-assem-rtn (name translate static-fn cond)
158        `(define-assembly-routine (,name
159                                   (:cost 10)
160                                   (:return-style :full-call)
161                                   (:policy :safe)
162                                   (:translate ,translate)
163                                   (:save-p t))
164                                  ((:arg x (descriptor-reg any-reg) a0-offset)
165                                   (:arg y (descriptor-reg any-reg) a1-offset)
166
167                                   (:res res descriptor-reg a0-offset)
168
169                                   (:temp lip interior-reg lip-offset)
170                                   (:temp lra descriptor-reg lra-offset)
171                                   (:temp nargs any-reg nargs-offset)
172                                   (:temp ocfp any-reg ocfp-offset))
173           (inst extru x 31 2 zero-tn :=)
174           (inst b do-static-fn :nullify t)
175           (inst extru y 31 2 zero-tn :=)
176           (inst b do-static-fn :nullify t)
177
178           (inst comclr x y zero-tn ,cond)
179           (inst move null-tn res :tr)
180           (load-symbol res t)
181           (lisp-return lra :offset 1)
182
183           DO-STATIC-FN
184           (inst ldw (static-fun-offset ',static-fn) null-tn lip)
185           (inst li (fixnumize 2) nargs)
186           (inst move cfp-tn ocfp)
187           (inst bv lip)
188           (inst move csp-tn cfp-tn))))
189
190   (define-cond-assem-rtn generic-< < two-arg-< :<)
191   (define-cond-assem-rtn generic-> > two-arg-> :>))
192
193
194 (define-assembly-routine
195     (generic-eql
196      (:cost 10)
197      (:return-style :full-call)
198      (:policy :safe)
199      (:translate eql)
200      (:save-p t))
201     ((:arg x (descriptor-reg any-reg) a0-offset)
202      (:arg y (descriptor-reg any-reg) a1-offset)
203
204      (:res res descriptor-reg a0-offset)
205
206      (:temp lip interior-reg lip-offset)
207      (:temp lra descriptor-reg lra-offset)
208      (:temp nargs any-reg nargs-offset)
209      (:temp ocfp any-reg ocfp-offset))
210
211   (inst comb := x y return-t :nullify t)
212   (inst extru x 31 2 zero-tn :<>)
213   (inst b return-nil :nullify t)
214   (inst extru y 31 2 zero-tn :=)
215   (inst b do-static-fn :nullify t)
216
217   RETURN-NIL
218   (inst move null-tn res)
219   (lisp-return lra :offset 1)
220
221   DO-STATIC-FN
222   (inst ldw (static-fun-offset 'eql) null-tn lip)
223   (inst li (fixnumize 2) nargs)
224   (inst move cfp-tn ocfp)
225   (inst bv lip)
226   (inst move csp-tn cfp-tn)
227
228   RETURN-T
229   (load-symbol res t))
230
231 (define-assembly-routine
232     (generic-=
233      (:cost 10)
234      (:return-style :full-call)
235      (:policy :safe)
236      (:translate =)
237      (:save-p t))
238     ((:arg x (descriptor-reg any-reg) a0-offset)
239      (:arg y (descriptor-reg any-reg) a1-offset)
240
241      (:res res descriptor-reg a0-offset)
242
243      (:temp lip interior-reg lip-offset)
244      (:temp lra descriptor-reg lra-offset)
245      (:temp nargs any-reg nargs-offset)
246      (:temp ocfp any-reg ocfp-offset))
247
248   (inst comb := x y return-t :nullify t)
249   (inst extru x 31 2 zero-tn :=)
250   (inst b do-static-fn :nullify t)
251   (inst extru y 31 2 zero-tn :=)
252   (inst b do-static-fn :nullify t)
253
254   (inst move null-tn res)
255   (lisp-return lra :offset 1)
256
257   DO-STATIC-FN
258   (inst ldw (static-fun-offset 'two-arg-=) null-tn lip)
259   (inst li (fixnumize 2) nargs)
260   (inst move cfp-tn ocfp)
261   (inst bv lip)
262   (inst move csp-tn cfp-tn)
263
264   RETURN-T
265   (load-symbol res t))