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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 12.3 KB
Line 
1;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;; Copyright 1994-2009 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
16
17
18
19(in-package "CCL")
20
21(defppclapfunction %fixnum-signum ((number arg_z))
22  (cmpri :cr0 number '0)
23  (li arg_z '0)
24  (beqlr :cr0)
25  (li arg_z '1)               ; assume positive
26  (bgtlr :cr0)
27  (li arg_z '-1)
28  (blr))
29
30; see %logcount (ppc-bignum.lisp)
31(defppclapfunction %ilogcount ((number arg_z))
32  (let ((arg imm0)
33        (shift imm1)
34        (temp imm2))
35    (unbox-fixnum arg number)
36    (mr. shift arg)
37    (li arg_z 0)
38    (b @test)
39    @next
40    (la temp -1 shift)
41    (and. shift shift temp)
42    (la arg_z '1 arg_z)
43    @test
44    (bne @next)
45    (blr)))
46
47(defppclapfunction %iash ((number arg_y) (count arg_z))
48  (unbox-fixnum imm1 count)
49  (unbox-fixnum imm0 number)
50  (neg. imm2 imm1)
51  (blt @left)
52  (srar imm0 imm0 imm2)
53  (box-fixnum arg_z imm0)
54  (blr)
55  @left
56  (slr arg_z number imm1)
57  (blr))
58
59(defparameter *double-float-zero* 0.0d0)
60(defparameter *short-float-zero* 0.0s0)
61
62
63#+ppc32-target
64(defppclapfunction %sfloat-hwords ((sfloat arg_z))
65  (lwz imm0 ppc32::single-float.value sfloat)
66  (digit-h temp0 imm0)
67  (digit-l temp1 imm0)
68  (vpush temp0)
69  (vpush temp1)
70  (la temp0 8 vsp)
71  (set-nargs 2)
72  (ba .SPvalues))
73
74
75; (integer-length arg) = (- 32 (cntlz (if (>= arg 0) arg (lognot arg))))
76#+ppc32-target
77(defppclapfunction %fixnum-intlen ((number arg_z)) 
78  (unbox-fixnum imm0 arg_z)
79  (cntlzw. imm1 imm0)                   ; testing result of cntlzw? - ah no zeros if neg
80  (bne @nonneg)
81  (not imm1 imm0)
82  (cntlzw imm1 imm1)
83  @nonneg
84  (subfic imm1 imm1 32)
85  (box-fixnum arg_z imm1)
86  (blr))
87
88#+ppc64-target
89(defppclapfunction %fixnum-intlen ((number arg_z)) 
90  (unbox-fixnum imm0 arg_z)
91  (cntlzd. imm1 imm0)
92  (bne @nonneg)
93  (not imm1 imm0)
94  (cntlzd imm1 imm1)
95  @nonneg
96  (subfic imm1 imm1 64)
97  (box-fixnum arg_z imm1)
98  (blr))
99
100
101
102
103;;; Caller guarantees that result fits in a fixnum.
104#+ppc32-target
105(defppclapfunction %truncate-double-float->fixnum ((arg arg_z))
106  (get-double-float fp0 arg)
107  (fctiwz fp0 fp0)
108  (stwu tsp -16 tsp)
109  (stw tsp 4 tsp)
110  (stfd fp0 8 tsp)
111  (lwz imm0 (+ 8 4) tsp)
112  (lwz tsp 0 tsp)
113  (box-fixnum arg_z imm0) 
114  (blr))
115
116#+ppc64-target
117(defppclapfunction %truncate-double-float->fixnum ((arg arg_z))
118  (get-double-float fp0 arg)
119  (fctidz fp0 fp0)
120  (stdu tsp -32 tsp)
121  (std tsp 8 tsp)
122  (stfd fp0 16 tsp)
123  (ld imm0 16 tsp)
124  (la tsp 32 tsp)
125  (box-fixnum arg_z imm0) 
126  (blr))
127
128#+ppc32-target
129(defppclapfunction %truncate-short-float->fixnum ((arg arg_z))
130  (get-single-float fp0 arg)
131  (fctiwz fp0 fp0)
132  (stwu tsp -16 tsp)
133  (stw tsp 4 tsp)
134  (stfd fp0 8 tsp)
135  (lwz imm0 (+ 8 4) tsp)
136  (lwz tsp 0 tsp)
137  (box-fixnum arg_z imm0) 
138  (blr))
139
140#+ppc64-target
141(defppclapfunction %truncate-short-float->fixnum ((arg arg_z))
142  (get-single-float fp0 arg)
143  (fctidz fp0 fp0)
144  (stdu tsp -32 tsp)
145  (std tsp 8 tsp)
146  (stfd fp0 16 tsp)
147  (ld imm0 16 tsp)
148  (la tsp 32 tsp)
149  (box-fixnum arg_z imm0) 
150  (blr))
151
152;;; DOES round to even
153#+ppc32-target
154(defppclapfunction %round-nearest-double-float->fixnum ((arg arg_z))
155  (get-double-float fp0 arg)
156  (fctiw fp0 fp0)
157  (stwu tsp -16 tsp)
158  (stw tsp 4 tsp)
159  (stfd fp0 8 tsp)
160  (lwz imm0 (+ 8 4) tsp)
161  (lwz tsp 0 tsp)
162  (box-fixnum arg_z imm0) 
163  (blr))
164
165#+ppc64-target
166(defppclapfunction %round-nearest-double-float->fixnum ((arg arg_z))
167  (get-double-float fp0 arg)
168  (fctid fp0 fp0)
169  (stdu tsp -32 tsp)
170  (std tsp 8 tsp)
171  (stfd fp0 16 tsp)
172  (ld imm0 16 tsp)
173  (la tsp 32 tsp)
174  (box-fixnum arg_z imm0) 
175  (blr))
176
177#+ppc32-target
178(defppclapfunction %round-nearest-short-float->fixnum ((arg arg_z))
179  (get-single-float fp0 arg)
180  (fctiw fp0 fp0)
181  (stwu tsp -16 tsp)
182  (stw tsp 4 tsp)
183  (stfd fp0 8 tsp)
184  (lwz imm0 (+ 8 4) tsp)
185  (lwz tsp 0 tsp)
186  (box-fixnum arg_z imm0) 
187  (blr))
188
189#+ppc64-target
190(defppclapfunction %round-nearest-short-float->fixnum ((arg arg_z))
191  (get-single-float fp0 arg)
192  (fctid fp0 fp0)
193  (stdu tsp -32 tsp)
194  (std tsp 8 tsp)
195  (stfd fp0 16 tsp)
196  (ld imm0 16 tsp)
197  (la tsp 32 tsp)
198  (box-fixnum arg_z imm0) 
199  (blr))
200
201
202
203
204;;; maybe this could be smarter but frankly scarlett I dont give a damn
205;;; ticket:666 describes one reason to 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    (cmpwi divisor '-1)   
216    (unbox-fixnum unboxed-dividend dividend)
217    (unbox-fixnum unboxed-divisor divisor)
218    (beq @neg)
219    (divwo. unboxed-quotient unboxed-dividend unboxed-divisor)          ; set OV if divisor = 0
220    (box-fixnum boxed-quotient unboxed-quotient)
221    (mullw unboxed-product unboxed-quotient unboxed-divisor)
222    (bns+ @ok)
223    (mtxer rzero)
224    (save-lisp-context)
225    (set-nargs 3)
226    (load-constant arg_x truncate)
227    (call-symbol divide-by-zero-error)
228    @not-0
229    @ok
230    (subf imm0 unboxed-product unboxed-dividend)
231    (vpush boxed-quotient)
232    (box-fixnum remainder imm0)
233    (vpush remainder)
234    (set-nargs 2)
235    (la temp0 8 vsp)
236    (ba .SPvalues)
237    @neg
238    (nego. dividend dividend)
239    (lwz arg_z '*least-positive-bignum* nfn)
240    (bns @ret)
241    (mtxer rzero)
242    (lwz dividend ppc32::symbol.vcell arg_z)
243    @ret
244    (mr temp0 vsp)
245    (vpush dividend)
246    (vpush rzero)
247    (set-nargs 2)
248    (ba .SPvalues)))
249
250#+ppc64-target
251(defppclapfunction %fixnum-truncate ((dividend arg_y) (divisor arg_z))
252  (let ((unboxed-quotient imm0)
253        (unboxed-dividend imm1)
254        (unboxed-divisor imm2)
255        (unboxed-product imm3)
256        (product temp0)
257        (boxed-quotient temp1)
258        (remainder temp2))
259    (cmpdi divisor '-1)
260    (unbox-fixnum unboxed-dividend dividend)
261    (unbox-fixnum unboxed-divisor divisor)
262    (beq @neg)
263    (divdo. unboxed-quotient unboxed-dividend unboxed-divisor)          ; set OV if divisor = 0
264    (box-fixnum boxed-quotient unboxed-quotient)
265    (mulld unboxed-product unboxed-quotient unboxed-divisor)
266    (bns+ @ok)
267    (mtxer rzero)
268    (save-lisp-context)
269    (set-nargs 3)
270    (load-constant arg_x truncate)
271    (call-symbol divide-by-zero-error)
272    @not-0
273    @ok
274    (subf imm0 unboxed-product unboxed-dividend)
275    (vpush boxed-quotient)
276    (box-fixnum remainder imm0)
277    (vpush remainder)
278    (set-nargs 2)
279    (la temp0 '2 vsp)
280    (ba .SPvalues)
281    @neg
282    (nego. dividend dividend)
283    (ld arg_z '*least-positive-bignum* nfn)
284    (bns @ret)
285    (mtxer rzero)
286    (ld dividend ppc64::symbol.vcell arg_z)
287    @ret
288    (mr temp0 vsp)
289    (vpush dividend)
290    (vpush rzero)
291    (set-nargs 2)
292    (ba .SPvalues)   
293    ))
294
295
296(defppclapfunction called-for-mv-p ()
297  (mr imm1 sp)
298  (ldr imm2 target::tcr.nfp target::rcontext)
299  (cmpr imm1 imm2)
300  (ref-global imm0 ret1valaddr)
301  (bne @notnfp)
302  (ldr imm1 0 imm1)
303  @notnfp
304  (ldr imm1 target::lisp-frame.savelr imm1)
305  (eq->boolean arg_z imm0 imm1 imm0)
306  (blr))
307
308;;; n1 and n2 must be positive (esp non zero)
309#+ppc32-target
310(defppclapfunction %fixnum-gcd ((n1 arg_y)(n2 arg_z))
311  (let ((temp imm0)
312        (u imm1)
313        (v imm2)
314        (ut0 imm3)
315        (vt0 imm4))
316    (unbox-fixnum u n1)
317    (unbox-fixnum v n2)
318    (neg temp u)
319    (and temp temp u)
320    (cntlzw ut0 temp)
321    (subfic ut0 ut0 31)
322    (neg temp v)
323    (and temp temp v)
324    (cntlzw vt0 temp)
325    (subfic vt0 vt0 31)
326    (cmpw cr2 ut0 vt0)
327    (srw u u ut0)
328    (srw v v vt0)
329    (addi ut0 ut0 ppc32::fixnum-shift)
330    (addi vt0 vt0 ppc32::fixnum-shift)
331    @loop
332    (cmpw cr0 u v)
333    (slw arg_z u ut0)
334    (bgt cr0 @u>v)
335    (blt cr0 @u<v)
336    (blelr cr2)
337    (slw arg_z u vt0)
338    (blr)
339    @u>v
340    (sub u u v)
341    @shiftu
342    (andi. temp u (ash 1 1))
343    (srwi u u 1)
344    (beq cr0 @shiftu)
345    (b @loop)
346    @u<v
347    (sub v v u)
348    @shiftv
349    (andi. temp v (ash 1 1))
350    (srwi v v 1)
351    (beq cr0 @shiftv)
352    (b @loop)))
353
354#+ppc64-target
355(defppclapfunction %fixnum-gcd ((n1 arg_y)(n2 arg_z))
356  (let ((temp imm0)
357        (u imm1)
358        (v imm2)
359        (ut0 imm3)
360        (vt0 imm4))
361    (unbox-fixnum u n1)
362    (unbox-fixnum v n2)
363    (neg temp u)
364    (and temp temp u)
365    (cntlzd ut0 temp)
366    (subfic ut0 ut0 63)
367    (neg temp v)
368    (and temp temp v)
369    (cntlzd vt0 temp)
370    (subfic vt0 vt0 63)
371    (cmpw cr2 ut0 vt0)
372    (srd u u ut0)
373    (srd v v vt0)
374    (addi ut0 ut0 ppc64::fixnum-shift)
375    (addi vt0 vt0 ppc64::fixnum-shift)
376    @loop
377    (cmpd cr0 u v)
378    (sld arg_z u ut0)
379    (bgt cr0 @u>v)
380    (blt cr0 @u<v)
381    (blelr cr2)
382    (sld arg_z u vt0)
383    (blr)
384    @u>v
385    (sub u u v)
386    @shiftu
387    (andi. temp u (ash 1 1))
388    (srdi u u 1)
389    (beq cr0 @shiftu)
390    (b @loop)
391    @u<v
392    (sub v v u)
393    @shiftv
394    (andi. temp v (ash 1 1))
395    (srdi v v 1)
396    (beq cr0 @shiftv)
397    (b @loop)))
398
399(defppclapfunction %mrg31k3p ((state arg_z))
400  (let ((seed temp0))
401    (svref seed 1 state)
402    (u32-ref imm0 1 seed)
403    (u32-ref imm3 2 seed)
404    (rlwinm imm1 imm0 22 1 9)
405    (srwi imm2 imm0 9)
406    (add imm0 imm1 imm2)
407   
408    ;; construct m1 (1- (expt 2 31))
409    (lis imm1 #x7fff)
410    (ori imm1 imm1 #xffff)
411
412    (rlwinm imm4 imm3 7 1 24)
413    (srwi imm5 imm3 24)
414    (add imm0 imm0 imm4)
415    (add imm0 imm0 imm5)
416
417    ;; reduce mod m1
418    (cmplw cr7 imm0 imm1)
419    (blt cr7 @ok1)
420    (sub imm0 imm0 imm1)
421    @ok1
422
423    (add imm0 imm0 imm3)
424
425    ;; reduce mod m1
426    (cmplw cr7 imm0 imm1)
427    (blt cr7 @ok2)
428    (sub imm0 imm0 imm1)
429    @ok2
430
431    ;; update state
432    (u32-ref imm1 1 seed)
433    (u32-set imm1 2 seed)
434    (u32-ref imm1 0 seed)
435    (u32-set imm1 1 seed)
436    (u32-set imm0 0 seed)
437
438    ;; construct m2 (- (expt 2 31) 21069))
439    (lis imm5 #x7fff)
440    (ori imm5 imm5 44467)
441
442    ;; second component
443    (u32-ref imm0 3 seed)
444    (rlwinm imm1 imm0 15 1 16)
445    (srwi imm2 imm0 16)
446    (mulli imm2 imm2 21069)
447    (add imm0 imm1 imm2)
448
449    ;; reduce mod m2
450    (cmplw cr7 imm0 imm5)
451    (blt cr7 @ok3)
452    (sub imm0 imm0 imm5)
453    @ok3
454
455    (u32-ref imm1 5 seed)
456    (rlwinm imm2 imm1 15 1 16)
457    (srwi imm3 imm1 16)
458    (mulli imm3 imm3 21069)
459    (add imm2 imm2 imm3)
460
461    ;; reduce mod m2
462    (cmplw cr7 imm2 imm5)
463    (blt cr7 @ok4)
464    (sub imm2 imm2 imm5)
465    @ok4
466
467    (add imm2 imm1 imm2)
468    (cmplw cr7 imm2 imm5)
469    (blt cr7 @ok5)
470    (sub imm2 imm2 imm5)
471    @ok5
472
473    (add imm2 imm2 imm0)
474    (cmplw cr7 imm2 imm5)
475    (blt cr7 @ok6)
476    (sub imm2 imm2 imm5)
477    @ok6
478
479    ;; update state
480    (u32-ref imm0 4 seed)
481    (u32-set imm0 5 seed)
482    (u32-ref imm0 3 seed)
483    (u32-set imm0 4 seed)
484    (u32-set imm2 3 seed)
485
486    ;; construct m1 (1- (expt 2 31))
487    (lis imm5 #x7fff)
488    (ori imm5 imm5 #xffff)
489
490    ;; combination
491    (u32-ref imm0 0 seed)
492    (cmplw cr7 imm0 imm2)
493    (sub imm0 imm0 imm2)
494    (bgt cr7 @finish)
495    (add imm0 imm0 imm5)
496    @finish
497    #+ppc32-target
498    (clrlwi imm0 imm0 3)                ;don't want negative fixnums
499    (box-fixnum arg_z imm0)
500    (blr)))
501
502
503(defppclapfunction %make-complex-double-float ((r arg_y) (i arg_z))
504  (get-double-float fp0 r)
505  (get-double-float fp1 i)
506  (li imm0 (logior (ash #+ppc32-target 5 #+ppc64-target 6 8) target::subtag-complex-double-float))
507  (subi allocptr allocptr (- #+ppc32=target 24 #+ppc64-target 32 target::fulltag-misc))
508  (twllt allocptr allocbase)
509  (str imm0 target::misc-header-offset allocptr)
510  (mr arg_z allocptr)
511  (clrrri allocptr allocptr target::ntagbits)
512  (stfd fp0 target::complex-double-float.realpart arg_z)
513  (stfd fp1 target::complex-double-float.imagpart arg_z)
514  (blr))
515
516(defppclapfunction %make-complex-single-float ((r arg_y) (i arg_z))
517  (get-single-float fp0 r)
518  (get-single-float fp1 i)
519  (li imm0 (logior (ash #+ppc32-target 3 #+ppc64-target 2 8) target::subtag-complex-single-float))
520  (subi allocptr allocptr (- 16 target::fulltag-misc))
521  (twllt allocptr allocbase)
522  (str imm0 target::misc-header-offset allocptr)
523  (mr arg_z allocptr)
524  (clrrri allocptr allocptr target::ntagbits)
525  (stfs fp0 target::complex-single-float.realpart arg_z)
526  (stfs fp1 target::complex-single-float.imagpart arg_z)
527  (blr))
528
529; End of ppc-numbers.lisp
Note: See TracBrowser for help on using the repository browser.