source: release/1.4/source/level-0/PPC/ppc-numbers.lisp @ 13535

Last change on this file since 13535 was 13535, checked in by rme, 10 years ago

Merge r13529 through r13532 (special-case divisor of -1 in %fixnum-truncate)
from trunk to 1.4 branch. Fixes ticket:666.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.7 KB
Line 
1;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18
19
20(in-package "CCL")
21
22;(push (cons 'number-case 1) *fred-special-indent-alist*) do later
23
24
25
26(defppclapfunction %fixnum-signum ((number arg_z))
27  (cmpri :cr0 number '0)
28  (li arg_z '0)
29  (beqlr :cr0)
30  (li arg_z '1)               ; assume positive
31  (bgtlr :cr0)
32  (li arg_z '-1)
33  (blr))
34
35; see %logcount (ppc-bignum.lisp)
36(defppclapfunction %ilogcount ((number arg_z))
37  (let ((arg imm0)
38        (shift imm1)
39        (temp imm2))
40    (unbox-fixnum arg number)
41    (mr. shift arg)
42    (li arg_z 0)
43    (b @test)
44    @next
45    (la temp -1 shift)
46    (and. shift shift temp)
47    (la arg_z '1 arg_z)
48    @test
49    (bne @next)
50    (blr)))
51
52(defppclapfunction %iash ((number arg_y) (count arg_z))
53  (unbox-fixnum imm1 count)
54  (unbox-fixnum imm0 number)
55  (neg. imm2 imm1)
56  (blt @left)
57  (srar imm0 imm0 imm2)
58  (box-fixnum arg_z imm0)
59  (blr)
60  @left
61  (slr arg_z number imm1)
62  (blr))
63
64(defparameter *double-float-zero* 0.0d0)
65(defparameter *short-float-zero* 0.0s0)
66
67
68#+ppc32-target
69(defppclapfunction %sfloat-hwords ((sfloat arg_z))
70  (lwz imm0 ppc32::single-float.value sfloat)
71  (digit-h temp0 imm0)
72  (digit-l temp1 imm0)
73  (vpush temp0)
74  (vpush temp1)
75  (la temp0 8 vsp)
76  (set-nargs 2)
77  (ba .SPvalues))
78
79
80; (integer-length arg) = (- 32 (cntlz (if (>= arg 0) arg (lognot arg))))
81#+ppc32-target
82(defppclapfunction %fixnum-intlen ((number arg_z)) 
83  (unbox-fixnum imm0 arg_z)
84  (cntlzw. imm1 imm0)                   ; testing result of cntlzw? - ah no zeros if neg
85  (bne @nonneg)
86  (not imm1 imm0)
87  (cntlzw imm1 imm1)
88  @nonneg
89  (subfic imm1 imm1 32)
90  (box-fixnum arg_z imm1)
91  (blr))
92
93#+ppc64-target
94(defppclapfunction %fixnum-intlen ((number arg_z)) 
95  (unbox-fixnum imm0 arg_z)
96  (cntlzd. imm1 imm0)
97  (bne @nonneg)
98  (not imm1 imm0)
99  (cntlzd imm1 imm1)
100  @nonneg
101  (subfic imm1 imm1 64)
102  (box-fixnum arg_z imm1)
103  (blr))
104
105
106
107
108;;; Caller guarantees that result fits in a fixnum.
109#+ppc32-target
110(defppclapfunction %truncate-double-float->fixnum ((arg arg_z))
111  (get-double-float fp0 arg)
112  (fctiwz fp0 fp0)
113  (stwu tsp -16 tsp)
114  (stw tsp 4 tsp)
115  (stfd fp0 8 tsp)
116  (lwz imm0 (+ 8 4) tsp)
117  (lwz tsp 0 tsp)
118  (box-fixnum arg_z imm0) 
119  (blr))
120
121#+ppc64-target
122(defppclapfunction %truncate-double-float->fixnum ((arg arg_z))
123  (get-double-float fp0 arg)
124  (fctidz fp0 fp0)
125  (stdu tsp -32 tsp)
126  (std tsp 8 tsp)
127  (stfd fp0 16 tsp)
128  (ld imm0 16 tsp)
129  (la tsp 32 tsp)
130  (box-fixnum arg_z imm0) 
131  (blr))
132
133#+ppc32-target
134(defppclapfunction %truncate-short-float->fixnum ((arg arg_z))
135  (get-single-float fp0 arg)
136  (fctiwz fp0 fp0)
137  (stwu tsp -16 tsp)
138  (stw tsp 4 tsp)
139  (stfd fp0 8 tsp)
140  (lwz imm0 (+ 8 4) tsp)
141  (lwz tsp 0 tsp)
142  (box-fixnum arg_z imm0) 
143  (blr))
144
145#+ppc64-target
146(defppclapfunction %truncate-short-float->fixnum ((arg arg_z))
147  (get-single-float fp0 arg)
148  (fctidz fp0 fp0)
149  (stdu tsp -32 tsp)
150  (std tsp 8 tsp)
151  (stfd fp0 16 tsp)
152  (ld imm0 16 tsp)
153  (la tsp 32 tsp)
154  (box-fixnum arg_z imm0) 
155  (blr))
156
157;;; DOES round to even
158#+ppc32-target
159(defppclapfunction %round-nearest-double-float->fixnum ((arg arg_z))
160  (get-double-float fp0 arg)
161  (fctiw fp0 fp0)
162  (stwu tsp -16 tsp)
163  (stw tsp 4 tsp)
164  (stfd fp0 8 tsp)
165  (lwz imm0 (+ 8 4) tsp)
166  (lwz tsp 0 tsp)
167  (box-fixnum arg_z imm0) 
168  (blr))
169
170#+ppc64-target
171(defppclapfunction %round-nearest-double-float->fixnum ((arg arg_z))
172  (get-double-float fp0 arg)
173  (fctid fp0 fp0)
174  (stdu tsp -32 tsp)
175  (std tsp 8 tsp)
176  (stfd fp0 16 tsp)
177  (ld imm0 16 tsp)
178  (la tsp 32 tsp)
179  (box-fixnum arg_z imm0) 
180  (blr))
181
182#+ppc32-target
183(defppclapfunction %round-nearest-short-float->fixnum ((arg arg_z))
184  (get-single-float fp0 arg)
185  (fctiw fp0 fp0)
186  (stwu tsp -16 tsp)
187  (stw tsp 4 tsp)
188  (stfd fp0 8 tsp)
189  (lwz imm0 (+ 8 4) tsp)
190  (lwz tsp 0 tsp)
191  (box-fixnum arg_z imm0) 
192  (blr))
193
194#+ppc64-target
195(defppclapfunction %round-nearest-short-float->fixnum ((arg arg_z))
196  (get-single-float fp0 arg)
197  (fctid fp0 fp0)
198  (stdu tsp -32 tsp)
199  (std tsp 8 tsp)
200  (stfd fp0 16 tsp)
201  (ld imm0 16 tsp)
202  (la tsp 32 tsp)
203  (box-fixnum arg_z imm0) 
204  (blr))
205
206
207
208
209;;; maybe this could be smarter but frankly scarlett I dont give a damn
210;;; ticket:666 describes one reason to give a damn.
211#+ppc32-target
212(defppclapfunction %fixnum-truncate ((dividend arg_y) (divisor arg_z))
213  (let ((unboxed-quotient imm0)
214        (unboxed-dividend imm1)
215        (unboxed-divisor imm2)
216        (unboxed-product imm3)
217        (product temp0)
218        (boxed-quotient temp1)
219        (remainder temp2))
220    (cmpwi divisor '-1)   
221    (unbox-fixnum unboxed-dividend dividend)
222    (unbox-fixnum unboxed-divisor divisor)
223    (beq @neg)
224    (divwo. unboxed-quotient unboxed-dividend unboxed-divisor)          ; set OV if divisor = 0
225    (box-fixnum boxed-quotient unboxed-quotient)
226    (mullw unboxed-product unboxed-quotient unboxed-divisor)
227    (bns+ @ok)
228    (mtxer rzero)
229    (save-lisp-context)
230    (set-nargs 3)
231    (load-constant arg_x truncate)
232    (call-symbol divide-by-zero-error)
233    @not-0
234    @ok
235    (subf imm0 unboxed-product unboxed-dividend)
236    (vpush boxed-quotient)
237    (box-fixnum remainder imm0)
238    (vpush remainder)
239    (set-nargs 2)
240    (la temp0 8 vsp)
241    (ba .SPvalues)
242    @neg
243    (nego. dividend dividend)
244    (lwz arg_z '*least-positive-bignum* nfn)
245    (bns @ret)
246    (mtxer rzero)
247    (lwz dividend ppc32::symbol.vcell arg_z)
248    @ret
249    (mr temp0 vsp)
250    (vpush dividend)
251    (vpush rzero)
252    (set-nargs 2)
253    (ba .SPvalues)))
254
255#+ppc64-target
256(defppclapfunction %fixnum-truncate ((dividend arg_y) (divisor arg_z))
257  (let ((unboxed-quotient imm0)
258        (unboxed-dividend imm1)
259        (unboxed-divisor imm2)
260        (unboxed-product imm3)
261        (product temp0)
262        (boxed-quotient temp1)
263        (remainder temp2))
264    (cmpdi divisor '-1)
265    (unbox-fixnum unboxed-dividend dividend)
266    (unbox-fixnum unboxed-divisor divisor)
267    (beq @neg)
268    (divdo. unboxed-quotient unboxed-dividend unboxed-divisor)          ; set OV if divisor = 0
269    (box-fixnum boxed-quotient unboxed-quotient)
270    (mulld unboxed-product unboxed-quotient unboxed-divisor)
271    (bns+ @ok)
272    (mtxer rzero)
273    (save-lisp-context)
274    (set-nargs 3)
275    (load-constant arg_x truncate)
276    (call-symbol divide-by-zero-error)
277    @not-0
278    @ok
279    (subf imm0 unboxed-product unboxed-dividend)
280    (vpush boxed-quotient)
281    (box-fixnum remainder imm0)
282    (vpush remainder)
283    (set-nargs 2)
284    (la temp0 '2 vsp)
285    (ba .SPvalues)
286    @neg
287    (nego. dividend dividend)
288    (ld arg_z '*least-positive-bignum* nfn)
289    (bns @ret)
290    (mtxer rzero)
291    (ld dividend ppc64::symbol.vcell arg_z)
292    @ret
293    (mr temp0 vsp)
294    (vpush dividend)
295    (vpush rzero)
296    (set-nargs 2)
297    (ba .SPvalues)   
298    ))
299
300
301(defppclapfunction called-for-mv-p ()
302  (ref-global imm0 ret1valaddr)
303  (ldr imm1 target::lisp-frame.savelr sp)
304  (eq->boolean arg_z imm0 imm1 imm0)
305  (blr))
306 
307
308
309
310
311
312
313
314#|
315Date: Mon, 3 Feb 1997 10:04:08 -0500
316To: info-mcl@digitool.com, wineberg@franz.scs.carleton.ca
317From: dds@flavors.com (Duncan Smith)
318Subject: Re: More info on the random number generator
319Sender: owner-info-mcl@digitool.com
320Precedence: bulk
321
322The generator is a Linear Congruential Generator:
323
324   X[n+1] = (aX[n] + c) mod m
325
326where: a = 16807  (Park&Miller recommend 48271)
327       c = 0
328       m = 2^31 - 1
329
330See: Knuth, Seminumerical Algorithms (Volume 2), Chapter 3.
331
332The period is: 2^31 - 2  (zero is excluded).
333
334What makes this generator so simple is that multiplication and addition mod
3352^n-1 is easy.  See Knuth Ch. 4.3.2 (2nd Ed. p 272).
336
337    ab mod m = ...
338
339If         m = 2^n-1
340           u = ab mod 2^n
341           v = floor( ab / 2^n )
342
343    ab mod m = u + v                   :  u+v < 2^n
344    ab mod m = ((u + v) mod 2^n) + 1   :  u+v >= 2^n
345
346What we do is use 2b and 2^n so we can do arithemetic mod 2^32 instead of
3472^31.  This reduces the whole generator to 5 instructions on the 680x0 or
34880x86, and 8 on the 60x.
349
350-Duncan
351
352|#
353; Use the two fixnums in state to generate a random fixnum >= 0 and < 65536
354; Scramble those fixnums up a bit.
355
356#+ppc32-target
357(defppclapfunction %next-random-pair ((high arg_y) (low arg_z))
358  (slwi imm0 high (- 16 ppc32::fixnumshift))
359  (rlwimi imm0 low (- 32 ppc32::fixnumshift) 16 31)
360  (lwi imm1 48271)
361  (clrlwi imm0 imm0 1)
362  (mullw imm0 imm1 imm0)
363  (clrrwi arg_y imm0 16 )
364  (srwi arg_y arg_y (- 16 ppc32::fixnumshift))
365  (clrlslwi arg_z imm0 16 ppc32::fixnumshift)
366  (mr temp0 vsp)
367  (vpush arg_y)
368  (vpush arg_z)
369  (set-nargs 2)
370  (ba .SPvalues))
371
372
373
374
375
376
377
378
379
380;;; n1 and n2 must be positive (esp non zero)
381#+ppc32-target
382(defppclapfunction %fixnum-gcd ((n1 arg_y)(n2 arg_z))
383  (let ((temp imm0)
384        (u imm1)
385        (v imm2)
386        (ut0 imm3)
387        (vt0 imm4))
388    (unbox-fixnum u n1)
389    (unbox-fixnum v n2)
390    (neg temp u)
391    (and temp temp u)
392    (cntlzw ut0 temp)
393    (subfic ut0 ut0 31)
394    (neg temp v)
395    (and temp temp v)
396    (cntlzw vt0 temp)
397    (subfic vt0 vt0 31)
398    (cmpw cr2 ut0 vt0)
399    (srw u u ut0)
400    (srw v v vt0)
401    (addi ut0 ut0 ppc32::fixnum-shift)
402    (addi vt0 vt0 ppc32::fixnum-shift)
403    @loop
404    (cmpw cr0 u v)
405    (slw arg_z u ut0)
406    (bgt cr0 @u>v)
407    (blt cr0 @u<v)
408    (blelr cr2)
409    (slw arg_z u vt0)
410    (blr)
411    @u>v
412    (sub u u v)
413    @shiftu
414    (andi. temp u (ash 1 1))
415    (srwi u u 1)
416    (beq cr0 @shiftu)
417    (b @loop)
418    @u<v
419    (sub v v u)
420    @shiftv
421    (andi. temp v (ash 1 1))
422    (srwi v v 1)
423    (beq cr0 @shiftv)
424    (b @loop)))
425
426#+ppc64-target
427(defppclapfunction %fixnum-gcd ((n1 arg_y)(n2 arg_z))
428  (let ((temp imm0)
429        (u imm1)
430        (v imm2)
431        (ut0 imm3)
432        (vt0 imm4))
433    (unbox-fixnum u n1)
434    (unbox-fixnum v n2)
435    (neg temp u)
436    (and temp temp u)
437    (cntlzd ut0 temp)
438    (subfic ut0 ut0 63)
439    (neg temp v)
440    (and temp temp v)
441    (cntlzd vt0 temp)
442    (subfic vt0 vt0 63)
443    (cmpw cr2 ut0 vt0)
444    (srd u u ut0)
445    (srd v v vt0)
446    (addi ut0 ut0 ppc64::fixnum-shift)
447    (addi vt0 vt0 ppc64::fixnum-shift)
448    @loop
449    (cmpd cr0 u v)
450    (sld arg_z u ut0)
451    (bgt cr0 @u>v)
452    (blt cr0 @u<v)
453    (blelr cr2)
454    (sld arg_z u vt0)
455    (blr)
456    @u>v
457    (sub u u v)
458    @shiftu
459    (andi. temp u (ash 1 1))
460    (srdi u u 1)
461    (beq cr0 @shiftu)
462    (b @loop)
463    @u<v
464    (sub v v u)
465    @shiftv
466    (andi. temp v (ash 1 1))
467    (srdi v v 1)
468    (beq cr0 @shiftv)
469    (b @loop)))
470   
471
472
473
474; End of ppc-numbers.lisp
Note: See TracBrowser for help on using the repository browser.