source: branches/arm/level-0/ARM/arm-numbers.lisp @ 14088

Last change on this file since 14088 was 14088, checked in by gb, 10 years ago

In %FIXNUM-TRUNCATE, set fn register so we can ref constant.

File size: 6.9 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(defarmlapfunction %fixnum-signum ((number arg_z))
23  (cmp number (:$ 0))
24  (movlt arg_z '-1)
25  (movgt arg_z '1)
26  (bx lr))
27
28(defarmlapfunction %ilogcount ((number arg_z))
29  (let ((arg imm0)
30        (shift imm1)
31        (temp imm2))
32    (unbox-fixnum arg number)
33    (movs shift arg)
34    (mov arg_z '0)
35    (b @test)
36    @next
37    (sub  temp shift (:$ 1))
38    (ands shift shift temp)
39    (add arg_z arg_z '1)
40    @test
41    (bne @next)
42    (bx lr)))
43
44(defarmlapfunction %iash ((number arg_y) (count arg_z))
45  (unbox-fixnum imm1 count)
46  (unbox-fixnum imm0 number)
47  (rsbs imm2 imm1 (:$ 0))
48  (blt @left)
49  (mov imm0 (:asr imm0 imm2))
50  (box-fixnum arg_z imm0)
51  (bx lr)
52  @left
53  (mov arg_z (:lsl number imm1))
54  (bx lr))
55
56(defparameter *double-float-zero* 0.0d0)
57(defparameter *short-float-zero* 0.0s0)
58
59
60(defarmlapfunction %sfloat-hwords ((sfloat arg_z))
61  (ldr imm0 (:@ sfloat (:$ arm::single-float.value)))
62  (digit-h temp0 imm0)
63  (digit-l temp1 imm0)
64  (vpush1 temp0)
65  (vpush1 temp1)
66  (add temp0 vsp '2)
67  (set-nargs 2)
68  (ba .SPvalues))
69
70
71; (integer-length arg) = (- 32 (clz (if (>= arg 0) arg (lognot arg))))
72(defarmlapfunction %fixnum-intlen ((number arg_z)) 
73  (unbox-fixnum imm0 arg_z)
74  (clz imm1 imm0)
75  (cmp imm1 (:$ 0))
76  (bne @nonneg)
77  (mvn imm1 imm0)
78  (clz imm1 imm1)
79  @nonneg
80  (rsb imm1 imm1 (:$ 32))
81  (box-fixnum arg_z imm1)
82  (bx lr))
83
84
85
86
87
88
89;;; Caller guarantees that result fits in a fixnum.
90(defarmlapfunction %truncate-double-float->fixnum ((arg arg_z))
91  (get-double-float d0 arg)
92  (ftosizd s2 d0)
93  (fmrs imm0 s2)
94  (box-fixnum arg_z imm0)
95  (bx lr))
96
97
98
99(defarmlapfunction %truncate-short-float->fixnum ((arg arg_z))
100  (get-single-float s0 arg imm0)
101  (ftosizs s2 s0)
102  (fmrs imm0 s2)
103  (box-fixnum arg_z imm0)
104  (bx lr))
105
106
107
108;;; DOES round to even
109
110(defarmlapfunction %round-nearest-double-float->fixnum ((arg arg_z))
111  (get-double-float d0 arg)
112  (ftosid s2 d0)
113  (fmrs imm0 s2)
114  (box-fixnum arg_z imm0)
115  (bx lr))
116
117
118
119(defarmlapfunction %round-nearest-short-float->fixnum ((arg arg_z))
120  (get-single-float s0 arg imm0)
121  (ftosis s2 s0)
122  (fmrs imm0 s2)
123  (box-fixnum arg_z imm0)
124  (bx lr))
125
126
127
128
129
130
131;;; maybe this could be smarter but frankly scarlett I dont give a damn
132;;; ticket:666 describes one reason to give a damn.
133(defarmlapfunction %fixnum-truncate ((dividend arg_y) (divisor arg_z))
134  (let ((unboxed-quotient imm0)
135        (unboxed-dividend imm0)
136        (unboxed-divisor imm1)
137        (unboxed-remainder imm1)
138        (quotient arg_y)
139        (remainder arg_z))
140    (build-lisp-frame)
141    (mov fn nfn)
142    (cmp divisor '-1)   
143    (unbox-fixnum unboxed-dividend dividend)
144    (unbox-fixnum unboxed-divisor divisor)
145    (beq @neg)
146    (bl .SPsdiv32)
147    (box-fixnum quotient unboxed-quotient)
148    (box-fixnum remainder unboxed-remainder)
149    (stmdb (:! vsp) (quotient remainder))
150    (set-nargs 2)
151    (ba .SPnvalret)
152    @neg
153    (ldr arg_z (:@ fn '*least-positive-bignum*))
154    (rsbs dividend dividend (:$ 0))
155    (ldrvs dividend (:@ arg_z (:$ arm::symbol.vcell)))
156    @ret
157    (mov temp0 (:$ 0))
158    (vpush1 dividend)
159    (vpush1 temp0)
160    (set-nargs 2)
161    (ba .SPnvalret)))
162
163
164
165
166(defarmlapfunction called-for-mv-p ()
167  (ref-global imm0 ret1valaddr)
168  (ldr imm1 (:@ sp (:$ arm::lisp-frame.savelr)))
169  (cmp imm1 imm0)
170  (mov arg_z 'nil)
171  (add arg_z arg_z (:$ arm::t-offset))
172  (bx lr))
173
174;;; n1 and n2 must be positive (esp non zero)
175;;; See <http://en.wikipedia.org/wiki/Binary_GCD_algorithm>
176(defarmlapfunction %fixnum-gcd ((n1 arg_y)(n2 arg_z))
177  (mov arg_x rcontext)                  ;need an extra imm reg
178  (unbox-fixnum imm0 n1)
179  (unbox-fixnum imm1 n2)
180  (subs r3 imm0 imm0)                   ; zero power-of-2 counter, set c flag
181  (orrs imm2 imm0 imm1)                 ; preserves carry, set other flags
182  @remove-twos-loop
183  (movsne imm2 (:lsr imm2 (:$ 1)))      ; carry = lsbit
184  (addcc r3 r3 (:$ 1))                  ; increment counter if lsbit 0
185  (bcc @remove-twos-loop)
186  (movs imm0 (:lsr imm0 r3))
187  (movsne imm1 (:lsr imm1 r3))
188  (beq @finish)
189  @check-two-r0
190  (movs imm0 (:lsr imm0 (:$ 1)))
191  (bcc @check-two-r0)
192  @check-two-r1
193  (movs imm1 (:lsr imm1 (:$ 1)))
194  (bcc @check-two-r1)
195  (subs imm1 imm1 imm0)
196  (addcc imm0 imm0 imm1)
197  (rsbcc imm1 imm1 (:$ 0))
198  (bne @check-two-r1)
199  (adc imm0 imm0 imm0)
200  @finish
201  (orr imm0 imm1 (:lsl imm0 r3))
202  (mov rcontext arg_x)
203  (box-fixnum arg_z imm0)
204  (bx lr))
205
206
207
208(defarmlapfunction %mrg31k3p ((state arg_z))
209  (let ((seed temp0)
210        (m1 #x7fffffff))
211    (svref seed 1 state)
212    (u32-ref imm0 1 seed)
213
214    (mov imm1 (:lsr imm0 (:$ 9)))
215    (mov imm2 (:lsl imm0 (:$ 23)))      ;get low 9 bits
216    (mov imm2 (:lsr imm2 (:$ 23)))
217    (add imm1 imm1 (:lsl imm2 (:$ 22)))
218
219    (u32-ref imm0 2 seed)
220    (add imm1 imm1 (:lsr imm0 (:$ 24)))
221    (bic imm2 imm0 (:$ #xff000000))
222    (add imm1 imm1 (:lsl imm2 (:$ 7)))
223
224    (cmp imm1 (:$ m1))
225    (subhi imm1 imm1 (:$ m1))
226
227    (add imm1 imm1 imm0)
228    (cmp imm1 (:$ m1))
229    (subhi imm1 imm1 (:$ m1))
230
231    (u32-ref imm0 1 seed)
232    (u32-set imm0 2 seed)
233    (u32-ref imm0 0 seed)
234    (u32-set imm0 1 seed)
235    (u32-set imm1 0 seed)
236
237    ;; second component
238    (u32-ref imm0 3 seed)
239    (mov imm1 (:$ 20992))
240    (add imm1 imm1 (:$ 77))
241    (mov imm2 (:lsr imm0 (:$ 16)))
242    (mul imm2 imm1 imm2)
243    (mov imm0 (:lsl imm0 (:$ 16)))
244    (add imm0 imm2 (:lsr imm0 (:$ 1)))
245
246    (ldr imm2 (:= @m2))
247    (cmp imm0 imm2)
248    (subhi imm0 imm0 imm2)
249
250    (vpush1 rcontext)
251    (mov rcontext imm0)                 ;save t1
252
253    (u32-ref imm0 5 seed)
254    (mov imm2 (:lsr imm0 (:$ 16)))
255    (mul imm2 imm1 imm2)                ;21069 still in imm1
256    (mov imm1 (:lsl imm0 (:$ 16)))
257    (add imm1 imm2 (:lsr imm1 (:$ 1)))
258
259    (ldr imm2 (:= @m2))
260    (cmp imm1 imm2)
261    (subhi imm1 imm1 imm2)
262
263    (add imm1 imm1 imm0)
264    (cmp imm1 imm2)
265    (subhi imm1 imm1 imm2)
266
267    (add imm1 imm1 rcontext)            ;add in t1 from back when
268    (vpop1 rcontext)
269    (cmp imm1 imm2)
270    (subhi imm1 imm1 imm2)
271
272    (u32-ref imm0 4 seed)
273    (u32-set imm0 5 seed)
274    (u32-ref imm0 3 seed)
275    (u32-set imm0 4 seed)
276    (u32-set imm1 3 seed)
277
278    ;; combination
279    (u32-ref imm0 0 seed)
280    (sub imm2 imm0 imm1)
281    (cmp imm0 imm1)
282    (addls imm2 imm2 (:$ m1))
283    (bic imm2 imm2 (:$ #xe0000000))     ;avoid negative fixnums
284    (box-fixnum arg_z imm2)
285    (bx lr))
286 
287  (:data)
288  @m2
289  (:word 2147462579))
290
291; End of arm-numbers.lisp
Note: See TracBrowser for help on using the repository browser.