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

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

Add/fix things.

File size: 6.8 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    (cmp divisor '-1)   
142    (unbox-fixnum unboxed-dividend dividend)
143    (unbox-fixnum unboxed-divisor divisor)
144    (beq @neg)
145    (bl .SPsdiv32)
146    (box-fixnum quotient unboxed-quotient)
147    (box-fixnum remainder unboxed-remainder)
148    (stmdb (:! vsp) (quotient remainder))
149    (set-nargs 2)
150    (ba .SPnvalret)
151    @neg
152    (ldr arg_z (:@ fn '*least-positive-bignum*))
153    (rsbs dividend dividend (:$ 0))
154    (ldrvs dividend (:@ arg_z (:$ arm::symbol.vcell)))
155    @ret
156    (mov temp0 (:$ 0))
157    (vpush1 dividend)
158    (vpush1 temp0)
159    (set-nargs 2)
160    (ba .SPnvalret)))
161
162
163
164
165(defarmlapfunction called-for-mv-p ()
166  (ref-global imm0 ret1valaddr)
167  (ldr imm1 (:@ sp (:$ arm::lisp-frame.savelr)))
168  (cmp imm1 imm0)
169  (mov arg_z 'nil)
170  (add arg_z arg_z (:$ arm::t-offset))
171  (bx lr))
172
173;;; n1 and n2 must be positive (esp non zero)
174;;; See <http://en.wikipedia.org/wiki/Binary_GCD_algorithm>
175(defarmlapfunction %fixnum-gcd ((n1 arg_y)(n2 arg_z))
176  (mov arg_x rcontext)                  ;need an extra imm reg
177  (unbox-fixnum imm0 n1)
178  (unbox-fixnum imm1 n2)
179  (subs r3 imm0 imm0)                   ; zero power-of-2 counter, set c flag
180  (orrs imm2 imm0 imm1)                 ; preserves carry, set other flags
181  @remove-twos-loop
182  (movsne imm2 (:lsr imm2 (:$ 1)))      ; carry = lsbit
183  (addcc r3 r3 (:$ 1))                  ; increment counter if lsbit 0
184  (bcc @remove-twos-loop)
185  (movs imm0 (:lsr imm0 r3))
186  (movsne imm1 (:lsr imm1 r3))
187  (beq @finish)
188  @check-two-r0
189  (movs imm0 (:lsr imm0 (:$ 1)))
190  (bcc @check-two-r0)
191  @check-two-r1
192  (movs imm1 (:lsr imm1 (:$ 1)))
193  (bcc @check-two-r1)
194  (subs imm1 imm1 imm0)
195  (addcc imm0 imm0 imm1)
196  (rsbcc imm1 imm1 (:$ 0))
197  (bne @check-two-r1)
198  (adc imm0 imm0 imm0)
199  @finish
200  (orr imm0 imm1 (:lsl imm0 r3))
201  (mov rcontext arg_x)
202  (box-fixnum arg_z imm0)
203  (bx lr))
204
205
206
207(defarmlapfunction %mrg31k3p ((state arg_z))
208  (let ((seed temp0)
209        (m1 #x7fffffff))
210    (svref seed 1 state)
211    (u32-ref imm0 1 seed)
212
213    (mov imm1 (:lsr imm0 (:$ 9)))
214    (mov imm2 (:lsl imm0 (:$ 23)))      ;get low 9 bits
215    (mov imm2 (:lsr imm2 (:$ 23)))
216    (add imm1 imm1 (:lsl imm2 (:$ 22)))
217
218    (u32-ref imm0 2 seed)
219    (add imm1 imm1 (:lsr imm0 (:$ 24)))
220    (bic imm2 imm0 (:$ #xff000000))
221    (add imm1 imm1 (:lsl imm2 (:$ 7)))
222
223    (cmp imm1 (:$ m1))
224    (subhi imm1 imm1 (:$ m1))
225
226    (add imm1 imm1 imm0)
227    (cmp imm1 (:$ m1))
228    (subhi imm1 imm1 (:$ m1))
229
230    (u32-ref imm0 1 seed)
231    (u32-set imm0 2 seed)
232    (u32-ref imm0 0 seed)
233    (u32-set imm0 1 seed)
234    (u32-set imm1 0 seed)
235
236    ;; second component
237    (u32-ref imm0 3 seed)
238    (mov imm1 (:$ 20992))
239    (add imm1 imm1 (:$ 77))
240    (mov imm2 (:lsr imm0 (:$ 16)))
241    (mul imm2 imm1 imm2)
242    (mov imm0 (:lsl imm0 (:$ 16)))
243    (add imm0 imm2 (:lsr imm0 (:$ 1)))
244
245    (ldr imm2 (:= @m2))
246    (cmp imm0 imm2)
247    (subhi imm0 imm0 imm2)
248
249    (vpush1 rcontext)
250    (mov rcontext imm0)                 ;save t1
251
252    (u32-ref imm0 5 seed)
253    (mov imm2 (:lsr imm0 (:$ 16)))
254    (mul imm2 imm1 imm2)                ;21069 still in imm1
255    (mov imm1 (:lsl imm0 (:$ 16)))
256    (add imm1 imm2 (:lsr imm1 (:$ 1)))
257
258    (ldr imm2 (:= @m2))
259    (cmp imm1 imm2)
260    (subhi imm1 imm1 imm2)
261
262    (add imm1 imm1 imm0)
263    (cmp imm1 imm2)
264    (subhi imm1 imm1 imm2)
265
266    (add imm1 imm1 rcontext)            ;add in t1 from back when
267    (vpop1 rcontext)
268    (cmp imm1 imm2)
269    (subhi imm1 imm1 imm2)
270
271    (u32-ref imm0 4 seed)
272    (u32-set imm0 5 seed)
273    (u32-ref imm0 3 seed)
274    (u32-set imm0 4 seed)
275    (u32-set imm1 3 seed)
276
277    ;; combination
278    (u32-ref imm0 0 seed)
279    (sub imm2 imm0 imm1)
280    (cmp imm0 imm1)
281    (addls imm2 imm2 (:$ m1))
282    (bic imm2 imm2 (:$ #xe0000000))     ;avoid negative fixnums
283    (box-fixnum arg_z imm2)
284    (bx lr))
285 
286  (:data)
287  @m2
288  (:word 2147462579))
289
290; End of arm-numbers.lisp
Note: See TracBrowser for help on using the repository browser.