source: trunk/source/level-0/PPC/ppc-numbers.lisp @ 13328

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

Remove now unused code implementing old random number generator.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 10.4 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(defppclapfunction %fixnum-signum ((number arg_z))
23  (cmpri :cr0 number '0)
24  (li arg_z '0)
25  (beqlr :cr0)
26  (li arg_z '1)               ; assume positive
27  (bgtlr :cr0)
28  (li arg_z '-1)
29  (blr))
30
31; see %logcount (ppc-bignum.lisp)
32(defppclapfunction %ilogcount ((number arg_z))
33  (let ((arg imm0)
34        (shift imm1)
35        (temp imm2))
36    (unbox-fixnum arg number)
37    (mr. shift arg)
38    (li arg_z 0)
39    (b @test)
40    @next
41    (la temp -1 shift)
42    (and. shift shift temp)
43    (la arg_z '1 arg_z)
44    @test
45    (bne @next)
46    (blr)))
47
48(defppclapfunction %iash ((number arg_y) (count arg_z))
49  (unbox-fixnum imm1 count)
50  (unbox-fixnum imm0 number)
51  (neg. imm2 imm1)
52  (blt @left)
53  (srar imm0 imm0 imm2)
54  (box-fixnum arg_z imm0)
55  (blr)
56  @left
57  (slr arg_z number imm1)
58  (blr))
59
60(defparameter *double-float-zero* 0.0d0)
61(defparameter *short-float-zero* 0.0s0)
62
63
64#+ppc32-target
65(defppclapfunction %sfloat-hwords ((sfloat arg_z))
66  (lwz imm0 ppc32::single-float.value sfloat)
67  (digit-h temp0 imm0)
68  (digit-l temp1 imm0)
69  (vpush temp0)
70  (vpush temp1)
71  (la temp0 8 vsp)
72  (set-nargs 2)
73  (ba .SPvalues))
74
75
76; (integer-length arg) = (- 32 (cntlz (if (>= arg 0) arg (lognot arg))))
77#+ppc32-target
78(defppclapfunction %fixnum-intlen ((number arg_z)) 
79  (unbox-fixnum imm0 arg_z)
80  (cntlzw. imm1 imm0)                   ; testing result of cntlzw? - ah no zeros if neg
81  (bne @nonneg)
82  (not imm1 imm0)
83  (cntlzw imm1 imm1)
84  @nonneg
85  (subfic imm1 imm1 32)
86  (box-fixnum arg_z imm1)
87  (blr))
88
89#+ppc64-target
90(defppclapfunction %fixnum-intlen ((number arg_z)) 
91  (unbox-fixnum imm0 arg_z)
92  (cntlzd. imm1 imm0)
93  (bne @nonneg)
94  (not imm1 imm0)
95  (cntlzd imm1 imm1)
96  @nonneg
97  (subfic imm1 imm1 64)
98  (box-fixnum arg_z imm1)
99  (blr))
100
101
102
103
104;;; Caller guarantees that result fits in a fixnum.
105#+ppc32-target
106(defppclapfunction %truncate-double-float->fixnum ((arg arg_z))
107  (get-double-float fp0 arg)
108  (fctiwz fp0 fp0)
109  (stwu tsp -16 tsp)
110  (stw tsp 4 tsp)
111  (stfd fp0 8 tsp)
112  (lwz imm0 (+ 8 4) tsp)
113  (lwz tsp 0 tsp)
114  (box-fixnum arg_z imm0) 
115  (blr))
116
117#+ppc64-target
118(defppclapfunction %truncate-double-float->fixnum ((arg arg_z))
119  (get-double-float fp0 arg)
120  (fctidz fp0 fp0)
121  (stdu tsp -32 tsp)
122  (std tsp 8 tsp)
123  (stfd fp0 16 tsp)
124  (ld imm0 16 tsp)
125  (la tsp 32 tsp)
126  (box-fixnum arg_z imm0) 
127  (blr))
128
129#+ppc32-target
130(defppclapfunction %truncate-short-float->fixnum ((arg arg_z))
131  (get-single-float fp0 arg)
132  (fctiwz fp0 fp0)
133  (stwu tsp -16 tsp)
134  (stw tsp 4 tsp)
135  (stfd fp0 8 tsp)
136  (lwz imm0 (+ 8 4) tsp)
137  (lwz tsp 0 tsp)
138  (box-fixnum arg_z imm0) 
139  (blr))
140
141#+ppc64-target
142(defppclapfunction %truncate-short-float->fixnum ((arg arg_z))
143  (get-single-float fp0 arg)
144  (fctidz fp0 fp0)
145  (stdu tsp -32 tsp)
146  (std tsp 8 tsp)
147  (stfd fp0 16 tsp)
148  (ld imm0 16 tsp)
149  (la tsp 32 tsp)
150  (box-fixnum arg_z imm0) 
151  (blr))
152
153;;; DOES round to even
154#+ppc32-target
155(defppclapfunction %round-nearest-double-float->fixnum ((arg arg_z))
156  (get-double-float fp0 arg)
157  (fctiw fp0 fp0)
158  (stwu tsp -16 tsp)
159  (stw tsp 4 tsp)
160  (stfd fp0 8 tsp)
161  (lwz imm0 (+ 8 4) tsp)
162  (lwz tsp 0 tsp)
163  (box-fixnum arg_z imm0) 
164  (blr))
165
166#+ppc64-target
167(defppclapfunction %round-nearest-double-float->fixnum ((arg arg_z))
168  (get-double-float fp0 arg)
169  (fctid fp0 fp0)
170  (stdu tsp -32 tsp)
171  (std tsp 8 tsp)
172  (stfd fp0 16 tsp)
173  (ld imm0 16 tsp)
174  (la tsp 32 tsp)
175  (box-fixnum arg_z imm0) 
176  (blr))
177
178#+ppc32-target
179(defppclapfunction %round-nearest-short-float->fixnum ((arg arg_z))
180  (get-single-float fp0 arg)
181  (fctiw fp0 fp0)
182  (stwu tsp -16 tsp)
183  (stw tsp 4 tsp)
184  (stfd fp0 8 tsp)
185  (lwz imm0 (+ 8 4) tsp)
186  (lwz tsp 0 tsp)
187  (box-fixnum arg_z imm0) 
188  (blr))
189
190#+ppc64-target
191(defppclapfunction %round-nearest-short-float->fixnum ((arg arg_z))
192  (get-single-float fp0 arg)
193  (fctid fp0 fp0)
194  (stdu tsp -32 tsp)
195  (std tsp 8 tsp)
196  (stfd fp0 16 tsp)
197  (ld imm0 16 tsp)
198  (la tsp 32 tsp)
199  (box-fixnum arg_z imm0) 
200  (blr))
201
202
203
204
205;;;; maybe this could be smarter but frankly scarlett I dont give a damn
206#+ppc32-target
207(defppclapfunction %fixnum-truncate ((dividend arg_y) (divisor arg_z))
208  (let ((unboxed-quotient imm0)
209        (unboxed-dividend imm1)
210        (unboxed-divisor imm2)
211        (unboxed-product imm3)
212        (product temp0)
213        (boxed-quotient temp1)
214        (remainder temp2))
215    (unbox-fixnum unboxed-dividend dividend)
216    (unbox-fixnum unboxed-divisor divisor)
217    (divwo. unboxed-quotient unboxed-dividend unboxed-divisor)          ; set OV if divisor = 0
218    (box-fixnum boxed-quotient unboxed-quotient)
219    (mullw unboxed-product unboxed-quotient unboxed-divisor)
220    (bns+ @ok)
221    (mtxer rzero)
222    (save-lisp-context)
223    (set-nargs 3)
224    (load-constant arg_x truncate)
225    (call-symbol divide-by-zero-error)
226    @not-0
227    @ok
228    (subf imm0 unboxed-product unboxed-dividend)
229    (vpush boxed-quotient)
230    (box-fixnum remainder imm0)
231    (vpush remainder)
232    (set-nargs 2)
233    (la temp0 8 vsp)
234    (ba .SPvalues)))
235
236#+ppc64-target
237(defppclapfunction %fixnum-truncate ((dividend arg_y) (divisor arg_z))
238  (let ((unboxed-quotient imm0)
239        (unboxed-dividend imm1)
240        (unboxed-divisor imm2)
241        (unboxed-product imm3)
242        (product temp0)
243        (boxed-quotient temp1)
244        (remainder temp2))
245    (unbox-fixnum unboxed-dividend dividend)
246    (unbox-fixnum unboxed-divisor divisor)
247    (divdo. unboxed-quotient unboxed-dividend unboxed-divisor)          ; set OV if divisor = 0
248    (box-fixnum boxed-quotient unboxed-quotient)
249    (mulld unboxed-product unboxed-quotient unboxed-divisor)
250    (bns+ @ok)
251    (mtxer rzero)
252    (save-lisp-context)
253    (set-nargs 3)
254    (load-constant arg_x truncate)
255    (call-symbol divide-by-zero-error)
256    @not-0
257    @ok
258    (subf imm0 unboxed-product unboxed-dividend)
259    (vpush boxed-quotient)
260    (box-fixnum remainder imm0)
261    (vpush remainder)
262    (set-nargs 2)
263    (la temp0 '2 vsp)
264    (ba .SPvalues)))
265
266
267(defppclapfunction called-for-mv-p ()
268  (ref-global imm0 ret1valaddr)
269  (ldr imm1 target::lisp-frame.savelr sp)
270  (eq->boolean arg_z imm0 imm1 imm0)
271  (blr))
272
273;;; n1 and n2 must be positive (esp non zero)
274#+ppc32-target
275(defppclapfunction %fixnum-gcd ((n1 arg_y)(n2 arg_z))
276  (let ((temp imm0)
277        (u imm1)
278        (v imm2)
279        (ut0 imm3)
280        (vt0 imm4))
281    (unbox-fixnum u n1)
282    (unbox-fixnum v n2)
283    (neg temp u)
284    (and temp temp u)
285    (cntlzw ut0 temp)
286    (subfic ut0 ut0 31)
287    (neg temp v)
288    (and temp temp v)
289    (cntlzw vt0 temp)
290    (subfic vt0 vt0 31)
291    (cmpw cr2 ut0 vt0)
292    (srw u u ut0)
293    (srw v v vt0)
294    (addi ut0 ut0 ppc32::fixnum-shift)
295    (addi vt0 vt0 ppc32::fixnum-shift)
296    @loop
297    (cmpw cr0 u v)
298    (slw arg_z u ut0)
299    (bgt cr0 @u>v)
300    (blt cr0 @u<v)
301    (blelr cr2)
302    (slw arg_z u vt0)
303    (blr)
304    @u>v
305    (sub u u v)
306    @shiftu
307    (andi. temp u (ash 1 1))
308    (srwi u u 1)
309    (beq cr0 @shiftu)
310    (b @loop)
311    @u<v
312    (sub v v u)
313    @shiftv
314    (andi. temp v (ash 1 1))
315    (srwi v v 1)
316    (beq cr0 @shiftv)
317    (b @loop)))
318
319#+ppc64-target
320(defppclapfunction %fixnum-gcd ((n1 arg_y)(n2 arg_z))
321  (let ((temp imm0)
322        (u imm1)
323        (v imm2)
324        (ut0 imm3)
325        (vt0 imm4))
326    (unbox-fixnum u n1)
327    (unbox-fixnum v n2)
328    (neg temp u)
329    (and temp temp u)
330    (cntlzd ut0 temp)
331    (subfic ut0 ut0 63)
332    (neg temp v)
333    (and temp temp v)
334    (cntlzd vt0 temp)
335    (subfic vt0 vt0 63)
336    (cmpw cr2 ut0 vt0)
337    (srd u u ut0)
338    (srd v v vt0)
339    (addi ut0 ut0 ppc64::fixnum-shift)
340    (addi vt0 vt0 ppc64::fixnum-shift)
341    @loop
342    (cmpd cr0 u v)
343    (sld arg_z u ut0)
344    (bgt cr0 @u>v)
345    (blt cr0 @u<v)
346    (blelr cr2)
347    (sld arg_z u vt0)
348    (blr)
349    @u>v
350    (sub u u v)
351    @shiftu
352    (andi. temp u (ash 1 1))
353    (srdi u u 1)
354    (beq cr0 @shiftu)
355    (b @loop)
356    @u<v
357    (sub v v u)
358    @shiftv
359    (andi. temp v (ash 1 1))
360    (srdi v v 1)
361    (beq cr0 @shiftv)
362    (b @loop)))
363
364(defppclapfunction %mrg31k3p ((state arg_z))
365  (let ((seed temp0))
366    (svref seed 1 state)
367    (u32-ref imm0 1 seed)
368    (u32-ref imm3 2 seed)
369    (rlwinm imm1 imm0 22 1 9)
370    (srwi imm2 imm0 9)
371    (add imm0 imm1 imm2)
372   
373    ;; construct m1 (1- (expt 2 31))
374    (lis imm1 #x7fff)
375    (ori imm1 imm1 #xffff)
376
377    (rlwinm imm4 imm3 7 1 24)
378    (srwi imm5 imm3 24)
379    (add imm0 imm0 imm4)
380    (add imm0 imm0 imm5)
381
382    ;; reduce mod m1
383    (cmplw cr7 imm0 imm1)
384    (blt cr7 @ok1)
385    (sub imm0 imm0 imm1)
386    @ok1
387
388    (add imm0 imm0 imm3)
389
390    ;; reduce mod m1
391    (cmplw cr7 imm0 imm1)
392    (blt cr7 @ok2)
393    (sub imm0 imm0 imm1)
394    @ok2
395
396    ;; update state
397    (u32-ref imm1 1 seed)
398    (u32-set imm1 2 seed)
399    (u32-ref imm1 0 seed)
400    (u32-set imm1 1 seed)
401    (u32-set imm0 0 seed)
402
403    ;; construct m2 (- (expt 2 31) 21069))
404    (lis imm5 #x7fff)
405    (ori imm5 imm5 44467)
406
407    ;; second component
408    (u32-ref imm0 3 seed)
409    (rlwinm imm1 imm0 15 1 16)
410    (srwi imm2 imm0 16)
411    (mulli imm2 imm2 21069)
412    (add imm0 imm1 imm2)
413
414    ;; reduce mod m2
415    (cmplw cr7 imm0 imm5)
416    (blt cr7 @ok3)
417    (sub imm0 imm0 imm5)
418    @ok3
419
420    (u32-ref imm1 5 seed)
421    (rlwinm imm2 imm1 15 1 16)
422    (srwi imm3 imm1 16)
423    (mulli imm3 imm3 21069)
424    (add imm2 imm2 imm3)
425
426    ;; reduce mod m2
427    (cmplw cr7 imm2 imm5)
428    (blt cr7 @ok4)
429    (sub imm2 imm2 imm5)
430    @ok4
431
432    (add imm2 imm1 imm2)
433    (cmplw cr7 imm2 imm5)
434    (blt cr7 @ok5)
435    (sub imm2 imm2 imm5)
436    @ok5
437
438    (add imm2 imm2 imm0)
439    (cmplw cr7 imm2 imm5)
440    (blt cr7 @ok6)
441    (sub imm2 imm2 imm5)
442    @ok6
443
444    ;; update state
445    (u32-ref imm0 4 seed)
446    (u32-set imm0 5 seed)
447    (u32-ref imm0 3 seed)
448    (u32-set imm0 4 seed)
449    (u32-set imm2 3 seed)
450
451    ;; construct m1 (1- (expt 2 31))
452    (lis imm5 #x7fff)
453    (ori imm5 imm5 #xffff)
454
455    ;; combination
456    (u32-ref imm0 0 seed)
457    (cmplw cr7 imm0 imm2)
458    (sub imm0 imm0 imm2)
459    (bgt cr7 @finish)
460    (add imm0 imm0 imm5)
461    @finish
462    #+ppc32-target
463    (clrlwi imm0 imm0 3)                ;don't want negative fixnums
464    (box-fixnum arg_z imm0)
465    (blr)))   
466
467; End of ppc-numbers.lisp
Note: See TracBrowser for help on using the repository browser.