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

Last change on this file since 14108 was 14108, checked in by gb, 11 years ago

arm-lapmacros: define LRI, which loads a 32-bit constant into a GPR via

movw/movt.

arm-numbers.lisp: use LRI in %MRG31K3P.
l1-init.lisp: *SAVE-SOURCE-LOCATIONS* T, for now.

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