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

Last change on this file since 4463 was 4463, checked in by gb, 14 years ago

Remove a quote from a LAP LOAD-CONSTANT form.

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