0.pre7.5:
[sbcl.git] / src / assembly / x86 / arith.lisp
1 ;;;; 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 \f
14 ;;;; addition, subtraction, and multiplication
15
16 (macrolet ((define-generic-arith-routine ((fun cost) &body body)
17              `(define-assembly-routine (,(symbolicate "GENERIC-" fun)
18                                         (:cost ,cost)
19                                         (:return-style :full-call)
20                                         (:translate ,fun)
21                                         (:policy :safe)
22                                         (:save-p t))
23                 ((:arg x (descriptor-reg any-reg) edx-offset)
24                  (:arg y (descriptor-reg any-reg)
25                        ;; this seems wrong esi-offset -- FIXME: What's it mean?
26                        edi-offset)
27
28                  (:res res (descriptor-reg any-reg) edx-offset)
29
30                  (:temp eax unsigned-reg eax-offset)
31                  (:temp ebx unsigned-reg ebx-offset)
32                  (:temp ecx unsigned-reg ecx-offset))
33
34                 (declare (ignorable ebx))
35
36                 (inst test x 3)  ; fixnum?
37                 (inst jmp :nz DO-STATIC-FUN) ; no - do generic
38                 (inst test y 3)  ; fixnum?
39                 (inst jmp :z DO-BODY)   ; yes - doit here
40
41                 DO-STATIC-FUN
42                 (inst pop eax)
43                 (inst push ebp-tn)
44                 (inst lea
45                       ebp-tn
46                       (make-ea :dword :base esp-tn :disp word-bytes))
47                 (inst sub esp-tn (fixnumize 2))
48                 (inst push eax)  ; callers return addr
49                 (inst mov ecx (fixnumize 2)) ; arg count
50                 (inst jmp
51                       (make-ea :dword
52                                :disp (+ nil-value
53                                         (static-function-offset
54                                          ',(symbolicate "TWO-ARG-" fun)))))
55
56                 DO-BODY
57                 ,@body)))
58
59   (define-generic-arith-routine (+ 10)
60     (move res x)
61     (inst add res y)
62     (inst jmp :no OKAY)
63     (inst rcr res 1)                  ; carry has correct sign
64     (inst sar res 1)                  ; remove type bits
65
66     (move ecx res)
67
68     (with-fixed-allocation (res bignum-type (1+ bignum-digits-offset))
69       (storew ecx res bignum-digits-offset other-pointer-type))
70
71     OKAY)
72
73   (define-generic-arith-routine (- 10)
74     ;; FIXME: This is screwed up.
75       ;;; I can't figure out the flags on subtract. Overflow never gets
76       ;;; set and carry always does. (- 0 most-negative-fixnum) can't be
77       ;;; easily detected so just let the upper level stuff do it.
78     (inst jmp DO-STATIC-FUN)
79
80     (move res x)
81     (inst sub res y)
82     (inst jmp :no OKAY)
83     (inst rcr res 1)
84     (inst sar res 1)                  ; remove type bits
85
86     (move ecx res)
87
88     (with-fixed-allocation (res bignum-type (1+ bignum-digits-offset))
89       (storew ecx res bignum-digits-offset other-pointer-type))
90     OKAY)
91
92   (define-generic-arith-routine (* 30)
93     (move eax x)                          ; must use eax for 64-bit result
94     (inst sar eax 2)                  ; remove *4 fixnum bias
95     (inst imul y)                        ; result in edx:eax
96     (inst jmp :no okay)            ; still fixnum
97
98     ;; zzz jrd changed edx to ebx in here, as edx isn't listed as a temp, above
99     ;;     pfw says that loses big -- edx is target for arg x and result res
100     ;;     note that 'edx' is not defined -- using x
101     (inst shrd eax x 2)            ; high bits from edx
102     (inst sar x 2)                      ; now shift edx too
103
104     (move ecx x)                          ; save high bits from cdq
105     (inst cdq)                      ; edx:eax <- sign-extend of eax
106     (inst cmp x ecx)
107     (inst jmp :e SINGLE-WORD-BIGNUM)
108
109     (with-fixed-allocation (res bignum-type (+ bignum-digits-offset 2))
110       (storew eax res bignum-digits-offset other-pointer-type)
111       (storew ecx res (1+ bignum-digits-offset) other-pointer-type))
112     (inst jmp DONE)
113
114     SINGLE-WORD-BIGNUM
115
116     (with-fixed-allocation (res bignum-type (1+ bignum-digits-offset))
117       (storew eax res bignum-digits-offset other-pointer-type))
118     (inst jmp DONE)
119
120     OKAY
121     (move res eax)
122     DONE))
123 \f
124 ;;;; negation
125
126 (define-assembly-routine (generic-negate
127                           (:cost 10)
128                           (:return-style :full-call)
129                           (:policy :safe)
130                           (:translate %negate)
131                           (:save-p t))
132                          ((:arg x (descriptor-reg any-reg) edx-offset)
133                           (:res res (descriptor-reg any-reg) edx-offset)
134
135                           (:temp eax unsigned-reg eax-offset)
136                           (:temp ecx unsigned-reg ecx-offset))
137   (inst test x 3)
138   (inst jmp :z FIXNUM)
139
140   (inst pop eax)
141   (inst push ebp-tn)
142   (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes))
143   (inst sub esp-tn (fixnumize 2))
144   (inst push eax)
145   (inst mov ecx (fixnumize 1))    ; arg count
146   (inst jmp (make-ea :dword
147                      :disp (+ nil-value (static-function-offset '%negate))))
148
149   FIXNUM
150   (move res x)
151   (inst neg res)                        ; (- most-negative-fixnum) is BIGNUM
152   (inst jmp :no OKAY)
153   (inst shr res 2)                    ; sign bit is data - remove type bits
154   (move ecx res)
155
156   (with-fixed-allocation (res bignum-type (1+ bignum-digits-offset))
157     (storew ecx res bignum-digits-offset other-pointer-type))
158
159   OKAY)
160 \f
161 ;;;; comparison
162
163 (macrolet ((define-cond-assem-rtn (name translate static-fn test)
164              `(define-assembly-routine (,name
165                                         (:cost 10)
166                                         (:return-style :full-call)
167                                         (:policy :safe)
168                                         (:translate ,translate)
169                                         (:save-p t))
170                 ((:arg x (descriptor-reg any-reg) edx-offset)
171                  (:arg y (descriptor-reg any-reg) edi-offset)
172
173                  (:res res descriptor-reg edx-offset)
174
175                  (:temp eax unsigned-reg eax-offset)
176                  (:temp ecx unsigned-reg ecx-offset))
177
178                 ;; KLUDGE: The "3" here is a mask for the bits which will be
179                 ;; zero in a fixnum. It should have a symbolic name. (Actually,
180                 ;; it might already have a symbolic name which the coder
181                 ;; couldn't be bothered to use..) -- WHN 19990917
182                 (inst test x 3)
183                 (inst jmp :nz TAIL-CALL-TO-STATIC-FN)
184                 (inst test y 3)
185                 (inst jmp :z INLINE-FIXNUM-COMPARE)
186
187                 TAIL-CALL-TO-STATIC-FN
188                 (inst pop eax)
189                 (inst push ebp-tn)
190                 (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes))
191                 (inst sub esp-tn (fixnumize 2)) ; FIXME: Push 2 words on stack,
192                                                 ; weirdly?
193                 (inst push eax)
194                 (inst mov ecx (fixnumize 2)) ; FIXME: FIXNUMIZE and
195                                         ; SINGLE-FLOAT-BITS are parallel,
196                                         ; should be named parallelly.
197                 (inst jmp (make-ea :dword
198                                    :disp (+ nil-value
199                                             (static-function-offset
200                                              ',static-fn))))
201
202                 INLINE-FIXNUM-COMPARE
203                 (inst cmp x y)
204                 (inst jmp ,test RETURN-TRUE)
205                 (inst mov res nil-value)
206                 ;; FIXME: A note explaining this return convention, or a
207                 ;; symbolic name for it, would be nice. (It looks as though we
208                 ;; should be hand-crafting the same return sequence as would be
209                 ;; produced by GENERATE-RETURN-SEQUENCE, but in that case it's
210                 ;; not clear why we don't just jump to the end of this function
211                 ;; to share the return sequence there.
212                 (inst pop eax)
213                 (inst add eax 2)
214                 (inst jmp eax)
215
216                 RETURN-TRUE
217                 (load-symbol res t))))
218
219   (define-cond-assem-rtn generic-< < two-arg-< :l)
220   (define-cond-assem-rtn generic-> > two-arg-> :g))
221
222 (define-assembly-routine (generic-eql
223                           (:cost 10)
224                           (:return-style :full-call)
225                           (:policy :safe)
226                           (:translate eql)
227                           (:save-p t))
228                          ((:arg x (descriptor-reg any-reg) edx-offset)
229                           (:arg y (descriptor-reg any-reg) edi-offset)
230
231                           (:res res descriptor-reg edx-offset)
232
233                           (:temp eax unsigned-reg eax-offset)
234                           (:temp ecx unsigned-reg ecx-offset))
235   (inst cmp x y)
236   (inst jmp :e RETURN-T)
237   (inst test x 3)
238   (inst jmp :z RETURN-NIL)
239   (inst test y 3)
240   (inst jmp :nz DO-STATIC-FN)
241
242   RETURN-NIL
243   (inst mov res nil-value)
244   (inst pop eax)
245   (inst add eax 2)
246   (inst jmp eax)
247
248   DO-STATIC-FN
249   (inst pop eax)
250   (inst push ebp-tn)
251   (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes))
252   (inst sub esp-tn (fixnumize 2))
253   (inst push eax)
254   (inst mov ecx (fixnumize 2))
255   (inst jmp (make-ea :dword
256                      :disp (+ nil-value (static-function-offset 'eql))))
257
258   RETURN-T
259   (load-symbol res t)
260   ;; FIXME: I don't understand how we return from here..
261   )
262
263 (define-assembly-routine (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) edx-offset)
270                           (:arg y (descriptor-reg any-reg) edi-offset)
271
272                           (:res res descriptor-reg edx-offset)
273
274                           (:temp eax unsigned-reg eax-offset)
275                           (:temp ecx unsigned-reg ecx-offset)
276                           )
277   (inst test x 3)                      ; descriptor?
278   (inst jmp :nz DO-STATIC-FN)          ; yes, do it here
279   (inst test y 3)                      ; descriptor?
280   (inst jmp :nz DO-STATIC-FN)
281   (inst cmp x y)
282   (inst jmp :e RETURN-T)                ; ok
283
284   (inst mov res nil-value)
285   (inst pop eax)
286   (inst add eax 2)
287   (inst jmp eax)
288
289   DO-STATIC-FN
290   (inst pop eax)
291   (inst push ebp-tn)
292   (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes))
293   (inst sub esp-tn (fixnumize 2))
294   (inst push eax)
295   (inst mov ecx (fixnumize 2))
296   (inst jmp (make-ea :dword
297                      :disp (+ nil-value (static-function-offset 'two-arg-=))))
298
299   RETURN-T
300   (load-symbol res t))
301
302 \f
303 ;;; Support for the Mersenne Twister, MT19937, random number generator
304 ;;; due to Matsumoto and Nishimura.
305 ;;;
306 ;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A
307 ;;; 623-dimensionally equidistributed uniform pseudorandom number
308 ;;; generator.", ACM Transactions on Modeling and Computer Simulation,
309 ;;; 1997, to appear.
310 ;;;
311 ;;; State:
312 ;;;  0-1:   Constant matrix A. [0, #x9908b0df] (not used here)
313 ;;;  2:     Index; init. to 1.
314 ;;;  3-626: State.
315
316 ;;; This assembly routine is called from the inline VOP and updates
317 ;;; the state vector with new random numbers. The state vector is
318 ;;; passed in the EAX register.
319 #+sb-assembling ; We don't want a vop for this one.
320 (define-assembly-routine
321     (random-mt19937-update)
322     ((:temp state unsigned-reg eax-offset)
323      (:temp k unsigned-reg ebx-offset)
324      (:temp y unsigned-reg ecx-offset)
325      (:temp tmp unsigned-reg edx-offset))
326
327   ;; Save the temporary registers.
328   (inst push k)
329   (inst push y)
330   (inst push tmp)
331
332   ;; Generate a new set of results.
333   (inst xor k k)
334   LOOP1
335   (inst mov y (make-ea :dword :base state :index k :scale 4
336                        :disp (- (* (+ 3 sb!vm:vector-data-offset)
337                                    sb!vm:word-bytes)
338                                 sb!vm:other-pointer-type)))
339   (inst mov tmp (make-ea :dword :base state :index k :scale 4
340                          :disp (- (* (+ 1 3 sb!vm:vector-data-offset)
341                                      sb!vm:word-bytes)
342                                   sb!vm:other-pointer-type)))
343   (inst and y #x80000000)
344   (inst and tmp #x7fffffff)
345   (inst or y tmp)
346   (inst shr y 1)
347   (inst jmp :nc skip1)
348   (inst xor y #x9908b0df)
349   SKIP1
350   (inst xor y (make-ea :dword :base state :index k :scale 4
351                        :disp (- (* (+ 397 3 sb!vm:vector-data-offset)
352                                    sb!vm:word-bytes)
353                                 sb!vm:other-pointer-type)))
354   (inst mov (make-ea :dword :base state :index k :scale 4
355                      :disp (- (* (+ 3 sb!vm:vector-data-offset)
356                                  sb!vm:word-bytes)
357                               sb!vm:other-pointer-type))
358         y)
359   (inst inc k)
360   (inst cmp k (- 624 397))
361   (inst jmp :b loop1)
362   LOOP2
363   (inst mov y (make-ea :dword :base state :index k :scale 4
364                        :disp (- (* (+ 3 sb!vm:vector-data-offset)
365                                    sb!vm:word-bytes)
366                                 sb!vm:other-pointer-type)))
367   (inst mov tmp (make-ea :dword :base state :index k :scale 4
368                          :disp (- (* (+ 1 3 sb!vm:vector-data-offset)
369                                      sb!vm:word-bytes)
370                                   sb!vm:other-pointer-type)))
371   (inst and y #x80000000)
372   (inst and tmp #x7fffffff)
373   (inst or y tmp)
374   (inst shr y 1)
375   (inst jmp :nc skip2)
376   (inst xor y #x9908b0df)
377   SKIP2
378   (inst xor y (make-ea :dword :base state :index k :scale 4
379                        :disp (- (* (+ (- 397 624) 3 sb!vm:vector-data-offset)
380                                    sb!vm:word-bytes)
381                                 sb!vm:other-pointer-type)))
382   (inst mov (make-ea :dword :base state :index k :scale 4
383                      :disp (- (* (+ 3 sb!vm:vector-data-offset)
384                                  sb!vm:word-bytes)
385                               sb!vm:other-pointer-type))
386         y)
387   (inst inc k)
388   (inst cmp k (- 624 1))
389   (inst jmp :b loop2)
390
391   (inst mov y (make-ea :dword :base state
392                        :disp (- (* (+ (- 624 1) 3 sb!vm:vector-data-offset)
393                                    sb!vm:word-bytes)
394                                 sb!vm:other-pointer-type)))
395   (inst mov tmp (make-ea :dword :base state
396                          :disp (- (* (+ 0 3 sb!vm:vector-data-offset)
397                                      sb!vm:word-bytes)
398                                   sb!vm:other-pointer-type)))
399   (inst and y #x80000000)
400   (inst and tmp #x7fffffff)
401   (inst or y tmp)
402   (inst shr y 1)
403   (inst jmp :nc skip3)
404   (inst xor y #x9908b0df)
405   SKIP3
406   (inst xor y (make-ea :dword :base state
407                        :disp (- (* (+ (- 397 1) 3 sb!vm:vector-data-offset)
408                                    sb!vm:word-bytes)
409                                 sb!vm:other-pointer-type)))
410   (inst mov (make-ea :dword :base state
411                      :disp (- (* (+ (- 624 1) 3 sb!vm:vector-data-offset)
412                                  sb!vm:word-bytes)
413                               sb!vm:other-pointer-type))
414         y)
415
416   ;; Restore the temporary registers and return.
417   (inst pop tmp)
418   (inst pop y)
419   (inst pop k)
420   (inst ret))