Don't go through fdefn when referencing #'known-functions.
[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 ecx unsigned-reg ecx-offset))
32
33                 (inst mov ecx x)
34                 (inst or ecx y)
35                 (inst test ecx fixnum-tag-mask)  ; both fixnums?
36                 (inst jmp :nz DO-STATIC-FUN)     ; no - do generic
37
38                 ,@body
39                 (inst clc) ; single-value return
40                 (inst ret)
41
42                 DO-STATIC-FUN
43                 ;; Same as: (inst enter (fixnumize 1))
44                 (inst push ebp-tn)
45                 (inst mov ebp-tn esp-tn)
46                 (inst sub esp-tn (fixnumize 1))
47                 (inst push (make-ea :dword :base ebp-tn
48                             :disp (frame-byte-offset return-pc-save-offset)))
49                 (inst mov ecx (fixnumize 2)) ; arg count
50                 (inst jmp
51                       (make-ea :dword
52                                :disp (+ nil-value
53                                         (static-fun-offset
54                                          ',(symbolicate "TWO-ARG-" fun))))))))
55
56   (define-generic-arith-routine (+ 10)
57     (move res x)
58     (inst add res y)
59     (inst jmp :no OKAY)
60     (inst rcr res 1)                  ; carry has correct sign
61     (inst sar res 1)                  ; remove type bits
62
63     (move ecx res)
64
65     (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
66       (storew ecx res bignum-digits-offset other-pointer-lowtag))
67
68     OKAY)
69
70   (define-generic-arith-routine (- 10)
71     (move res x)
72     (inst sub res y)
73     (inst jmp :no OKAY)
74     (inst cmc)                        ; carry has correct sign now
75     (inst rcr res 1)
76     (inst sar res 1)                  ; remove type bits
77
78     (move ecx res)
79
80     (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
81       (storew ecx res bignum-digits-offset other-pointer-lowtag))
82     OKAY)
83
84   (define-generic-arith-routine (* 30)
85     (move eax x)                          ; must use eax for 64-bit result
86     (inst sar eax n-fixnum-tag-bits)      ; remove *4 fixnum bias
87     (inst imul y)                         ; result in edx:eax
88     (inst jmp :no OKAY)                   ; still fixnum
89
90     ;; zzz jrd changed edx to ebx in here, as edx isn't listed as a temp, above
91     ;;     pfw says that loses big -- edx is target for arg x and result res
92     ;;     note that 'edx' is not defined -- using x
93     (inst shrd eax x n-fixnum-tag-bits)    ; high bits from edx
94     (inst sar x n-fixnum-tag-bits)         ; now shift edx too
95
96     (move ecx x)                           ; save high bits from cdq
97     (inst cdq)                             ; edx:eax <- sign-extend of eax
98     (inst cmp x ecx)
99     (inst jmp :e SINGLE-WORD-BIGNUM)
100
101     (with-fixed-allocation (res bignum-widetag (+ bignum-digits-offset 2))
102       (storew eax res bignum-digits-offset other-pointer-lowtag)
103       (storew ecx res (1+ bignum-digits-offset) other-pointer-lowtag))
104     (inst jmp DONE)
105
106     SINGLE-WORD-BIGNUM
107
108     (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
109       (storew eax res bignum-digits-offset other-pointer-lowtag))
110     (inst jmp DONE)
111
112     OKAY
113     (move res eax)
114     DONE))
115 \f
116 ;;;; negation
117
118 (define-assembly-routine (generic-negate
119                           (:cost 10)
120                           (:return-style :full-call)
121                           (:policy :safe)
122                           (:translate %negate)
123                           (:save-p t))
124                          ((:arg x (descriptor-reg any-reg) edx-offset)
125                           (:res res (descriptor-reg any-reg) edx-offset)
126
127                           (:temp eax unsigned-reg eax-offset)
128                           (:temp ecx unsigned-reg ecx-offset))
129   (inst test x fixnum-tag-mask)
130   (inst jmp :z FIXNUM)
131
132   (inst push ebp-tn)
133   (inst mov ebp-tn esp-tn)
134   (inst sub esp-tn (fixnumize 1))
135   (inst push (make-ea :dword :base ebp-tn
136                       :disp (frame-byte-offset return-pc-save-offset)))
137   (inst mov ecx (fixnumize 1))    ; arg count
138   (inst jmp (make-ea :dword
139                      :disp (+ nil-value (static-fun-offset '%negate))))
140
141   FIXNUM
142   (move res x)
143   (inst neg res)                        ; (- most-negative-fixnum) is BIGNUM
144   (inst jmp :no OKAY)
145   (inst shr res n-fixnum-tag-bits)      ; sign bit is data - remove type bits
146   (move ecx res)
147
148   (with-fixed-allocation (res bignum-widetag (1+ bignum-digits-offset))
149     (storew ecx res bignum-digits-offset other-pointer-lowtag))
150
151   OKAY)
152 \f
153 ;;;; comparison
154
155 (macrolet ((define-cond-assem-rtn (name translate static-fn test)
156              #+sb-assembling
157              `(define-assembly-routine (,name
158                                         (:return-style :none))
159                 ((:arg x (descriptor-reg any-reg) edx-offset)
160                  (:arg y (descriptor-reg any-reg) edi-offset)
161
162                  (:temp ecx unsigned-reg ecx-offset))
163
164                 (inst mov ecx x)
165                 (inst or ecx y)
166                 (inst test ecx fixnum-tag-mask)
167                 (inst jmp :nz DO-STATIC-FUN)  ; are both fixnums?
168
169                 (inst cmp x y)
170                 (inst ret)
171
172                 DO-STATIC-FUN
173                 (inst push ebp-tn)
174                 (inst mov ebp-tn esp-tn)
175                 (inst sub esp-tn (fixnumize 3))
176                 (inst mov (make-ea :dword :base esp-tn
177                                    :disp (frame-byte-offset
178                                           (+ sp->fp-offset
179                                              -3
180                                              ocfp-save-offset)))
181                       ebp-tn)
182                 (inst lea ebp-tn (make-ea :dword :base esp-tn
183                                           :disp (frame-byte-offset
184                                           (+ sp->fp-offset
185                                              -3
186                                              ocfp-save-offset))))
187                 (inst mov ecx (fixnumize 2))
188                 (inst call (make-ea :dword
189                                     :disp (+ nil-value
190                                              (static-fun-offset ',static-fn))))
191                 ;; HACK: We depend on NIL having the lowest address of all
192                 ;; static symbols (including T)
193                 ,@(ecase test
194                     (:l `((inst mov y (1+ nil-value))
195                           (inst cmp y x)))
196                     (:g `((inst cmp x (1+ nil-value)))))
197                 (inst pop ebp-tn)
198                 (inst ret))
199              #-sb-assembling
200              `(define-vop (,name)
201                 (:translate ,translate)
202                 (:policy :safe)
203                 (:save-p t)
204                 (:args (x :scs (descriptor-reg any-reg) :target edx)
205                        (y :scs (descriptor-reg any-reg) :target edi))
206
207                 (:temporary (:sc unsigned-reg :offset edx-offset
208                                  :from (:argument 0))
209                             edx)
210                 (:temporary (:sc unsigned-reg :offset edi-offset
211                                  :from (:argument 1))
212                             edi)
213                 (:conditional ,test)
214                 (:generator 10
215                    (move edx x)
216                    (move edi y)
217                    (inst call (make-fixup ',name :assembly-routine))))))
218
219   (define-cond-assem-rtn generic-< < two-arg-< :l)
220   (define-cond-assem-rtn generic-> > two-arg-> :g))
221
222 #+sb-assembling
223 (define-assembly-routine (generic-eql
224                           (:return-style :none))
225                          ((:arg x (descriptor-reg any-reg) edx-offset)
226                           (:arg y (descriptor-reg any-reg) edi-offset)
227
228                           (:temp ecx unsigned-reg ecx-offset))
229   (inst mov ecx x)
230   (inst and ecx y)
231   (inst and ecx lowtag-mask)
232   (inst cmp ecx other-pointer-lowtag)
233   (inst jmp :e DO-STATIC-FUN)
234
235   ;; At least one fixnum
236   (inst cmp x y)
237   RET
238   (inst ret)
239
240   DO-STATIC-FUN
241   ;; Might as well fast path that...
242   (inst cmp x y)
243   (inst jmp :e RET)
244
245   (inst push ebp-tn)
246   (inst mov ebp-tn esp-tn)
247   (inst sub esp-tn (fixnumize 3))
248   (inst mov (make-ea :dword :base esp-tn
249                      :disp (frame-byte-offset
250                             (+ sp->fp-offset
251                                -3
252                                ocfp-save-offset)))
253         ebp-tn)
254   (inst lea ebp-tn (make-ea :dword :base esp-tn
255                             :disp (frame-byte-offset
256                                    (+ sp->fp-offset
257                                       -3
258                                       ocfp-save-offset))))
259   (inst mov ecx (fixnumize 2))
260   (inst call (make-ea :dword
261                       :disp (+ nil-value (static-fun-offset 'eql))))
262   (load-symbol y t)
263   (inst cmp x y)
264   (inst pop ebp-tn)
265   (inst ret))
266
267 #-sb-assembling
268 (define-vop (generic-eql)
269   (:translate eql)
270   (:policy :safe)
271   (:save-p t)
272   (:args (x :scs (descriptor-reg any-reg) :target edx)
273          (y :scs (descriptor-reg any-reg) :target edi))
274
275   (:temporary (:sc unsigned-reg :offset edx-offset
276                :from (:argument 0))
277               edx)
278   (:temporary (:sc unsigned-reg :offset edi-offset
279                :from (:argument 1))
280               edi)
281
282   (:conditional :e)
283   (:generator 10
284     (move edx x)
285     (move edi y)
286     (inst call (make-fixup 'generic-eql :assembly-routine))))
287
288 #+sb-assembling
289 (define-assembly-routine (generic-=
290                           (:return-style :none))
291                          ((:arg x (descriptor-reg any-reg) edx-offset)
292                           (:arg y (descriptor-reg any-reg) edi-offset)
293
294                           (:temp ecx unsigned-reg ecx-offset))
295   (inst mov ecx x)
296   (inst or ecx y)
297   (inst test ecx fixnum-tag-mask)
298   (inst jmp :nz DO-STATIC-FUN)
299
300   ;; Both fixnums
301   (inst cmp x y)
302   (inst ret)
303
304   DO-STATIC-FUN
305   (inst push ebp-tn)
306   (inst mov ebp-tn esp-tn)
307   (inst sub esp-tn (fixnumize 3))
308   (inst mov (make-ea :dword :base esp-tn
309                      :disp (frame-byte-offset
310                             (+ sp->fp-offset
311                                -3
312                                ocfp-save-offset)))
313         ebp-tn)
314   (inst lea ebp-tn (make-ea :dword :base esp-tn
315                             :disp (frame-byte-offset
316                                    (+ sp->fp-offset
317                                       -3
318                                       ocfp-save-offset))))
319   (inst mov ecx (fixnumize 2))
320   (inst call (make-ea :dword
321                       :disp (+ nil-value (static-fun-offset 'two-arg-=))))
322   (load-symbol y t)
323   (inst cmp x y)
324   (inst pop ebp-tn)
325   (inst ret))
326
327 #-sb-assembling
328 (define-vop (generic-=)
329   (:translate =)
330   (:policy :safe)
331   (:save-p t)
332   (:args (x :scs (descriptor-reg any-reg) :target edx)
333          (y :scs (descriptor-reg any-reg) :target edi))
334
335   (:temporary (:sc unsigned-reg :offset edx-offset
336                :from (:argument 0))
337               edx)
338   (:temporary (:sc unsigned-reg :offset edi-offset
339                :from (:argument 1))
340               edi)
341
342   (:conditional :e)
343   (:generator 10
344     (move edx x)
345     (move edi y)
346     (inst call (make-fixup 'generic-= :assembly-routine))))
347
348 \f
349 ;;; Support for the Mersenne Twister, MT19937, random number generator
350 ;;; due to Matsumoto and Nishimura.
351 ;;;
352 ;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A
353 ;;; 623-dimensionally equidistributed uniform pseudorandom number
354 ;;; generator.", ACM Transactions on Modeling and Computer Simulation,
355 ;;; 1997, to appear.
356 ;;;
357 ;;; State:
358 ;;;  0-1:   Constant matrix A. [0, #x9908b0df] (not used here)
359 ;;;  2:     Index; init. to 1.
360 ;;;  3-626: State.
361
362 ;;; This assembly routine is called from the inline VOP and updates
363 ;;; the state vector with new random numbers. The state vector is
364 ;;; passed in the EAX register.
365 #+sb-assembling ; We don't want a vop for this one.
366 (define-assembly-routine
367     (random-mt19937-update)
368     ((:temp state unsigned-reg eax-offset)
369      (:temp k unsigned-reg ebx-offset)
370      (:temp y unsigned-reg ecx-offset)
371      (:temp tmp unsigned-reg edx-offset))
372
373   ;; Save the temporary registers.
374   (inst push k)
375   (inst push y)
376   (inst push tmp)
377
378   ;; Generate a new set of results.
379   (inst xor k k)
380   LOOP1
381   (inst mov y (make-ea-for-vector-data state :index k :offset 3))
382   (inst mov tmp (make-ea-for-vector-data state :index k :offset (+ 1 3)))
383   (inst and y #x80000000)
384   (inst and tmp #x7fffffff)
385   (inst or y tmp)
386   (inst shr y 1)
387   (inst jmp :nc skip1)
388   (inst xor y #x9908b0df)
389   SKIP1
390   (inst xor y (make-ea-for-vector-data state :index k :offset (+ 397 3)))
391   (inst mov (make-ea-for-vector-data state :index k :offset 3) y)
392   (inst inc k)
393   (inst cmp k (- 624 397))
394   (inst jmp :b loop1)
395   LOOP2
396   (inst mov y (make-ea-for-vector-data state :index k :offset 3))
397   (inst mov tmp (make-ea-for-vector-data state :index k :offset (+ 1 3)))
398   (inst and y #x80000000)
399   (inst and tmp #x7fffffff)
400   (inst or y tmp)
401   (inst shr y 1)
402   (inst jmp :nc skip2)
403   (inst xor y #x9908b0df)
404   SKIP2
405   (inst xor y (make-ea-for-vector-data state :index k :offset (+ (- 397 624) 3)))
406   (inst mov (make-ea-for-vector-data state :index k :offset 3) y)
407   (inst inc k)
408   (inst cmp k (- 624 1))
409   (inst jmp :b loop2)
410
411   (inst mov y (make-ea-for-vector-data state :offset (+ (- 624 1) 3)))
412   (inst mov tmp (make-ea-for-vector-data state :offset (+ 0 3)))
413   (inst and y #x80000000)
414   (inst and tmp #x7fffffff)
415   (inst or y tmp)
416   (inst shr y 1)
417   (inst jmp :nc skip3)
418   (inst xor y #x9908b0df)
419   SKIP3
420   (inst xor y (make-ea-for-vector-data state :offset (+ (- 397 1) 3)))
421   (inst mov (make-ea-for-vector-data state :offset (+ (- 624 1) 3)) y)
422
423   ;; Restore the temporary registers and return.
424   (inst pop tmp)
425   (inst pop y)
426   (inst pop k)
427   (inst ret))