source: trunk/source/level-0/ARM/arm-array.lisp @ 15601

Last change on this file since 15601 was 15165, checked in by gb, 8 years ago

Except on the PPC (which has LAP versions of %EXTEND-VECTOR), define
%EXTEND-VECTOR in terms of %UVECTOR-REPLACE, which can use things like
%COPY-IVECTOR-TO-IVECTOR.

Make %UVECTOR-REPLACE work on non-CL-array uvector types, too.

When creating an fd-based stream (in MAKE-FD-STREAM and MAKE-FILE-STREAM),
if the stream is capable of character I/O it'll be buffered by an octet
vector, so call OPTIMAL-BUFFER-SIZE with the appropriate element type.
On Windows, use the arbitrary buffer size of 4K octets (rather than #$BUFSIZ).

In %IOBLOCK-UNENCODED-READ-LINE, if we haven't seen a newline in the first
few bufferfuls of data, stop expecting to do so (and grow the string in
larger increments less often.)

In the more generic READ-LINE cases, use a SIMPLE-STRING (and track
its length and current position manually) rather than a string with a
fill-pointer.

File size: 12.9 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2010 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL 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(in-package "CCL")
18
19(eval-when (:compile-toplevel :execute)
20  (require "ARM-ARCH")
21  (require "ARM-LAPMACROS"))
22
23
24;;; Users of this shouldn't make assumptions about return value.
25
26
27(eval-when (:compile-toplevel :execute)
28;;; Assumptions made by %init-misc
29  (assert (and (< arm::max-32-bit-ivector-subtag
30                  arm::max-8-bit-ivector-subtag
31                  arm::max-16-bit-ivector-subtag)
32               (eql arm::max-32-bit-ivector-subtag arm::subtag-simple-base-string)
33               (eql arm::max-16-bit-ivector-subtag arm::subtag-s16-vector)
34               (eql arm::max-8-bit-ivector-subtag 223))))
35
36
37(defarmlapfunction %init-misc ((val arg_y)
38                               (miscobj arg_z))
39  (getvheader imm0 miscobj)
40  (bic temp1 imm0 (:$ arm::subtag-mask))
41  (movs temp1 (:lsr temp1 (:$ (- arm::num-subtag-bits arm::fixnumshift))))
42  (extract-lowbyte imm2 imm0)
43  (extract-fulltag imm1 imm0)
44  (bxeq lr)
45  (cmp imm1 (:$ arm::fulltag-nodeheader))
46  (bne @ivector)
47  (mov imm1 (:$ arm::misc-data-offset))
48  @node-loop
49  (subs temp1 temp1 '1)
50  (str val (:@ miscobj imm1))
51  (add imm1 imm1 '1)
52  (bne @node-loop)
53  (bx lr)
54  @ivector
55  (build-lisp-frame imm0)
56  (mov imm1 (:$ arm::misc-data-offset))
57  (mov imm2 (:lsr imm2 (:$ 3)))
58  (bl @dispatch)
59  (b @u32)                              ;bignum,0
60  (b @u32)                              ;single-float
61  (b @u32)                              ;double-float
62  (b @u32)                              ;macptr
63  (b @u32)                              ;dead-macptr
64  (b @u32)                              ;code-vector, 5
65  (b @bad)
66  (b @bad)
67  (b @bad)
68  (b @bad)
69  (b @bad)
70  (b @bad)
71  (b @bad)
72  (b @bad)
73  (b @bad)
74  (b @bad)
75  (b @bad)
76  (b @bad)
77  (b @bad)
78  (b @bad)
79  (b @single-float-vector)              ;20
80  (b @u32)
81  (b @s32)
82  (b @fixnum)
83  (b @string)
84  (b @u8)
85  (b @s8)
86  (b @string8)
87  (b @u16)
88  (b @s16)
89  (b @double-float-vector)
90  (b @bit-vector)
91  @dispatch
92  (add pc lr (:lsl imm2 (:$ arm::word-shift)))
93  @u32
94  ;; Non-negative fixnum, positive one-digit bignum, two-digit bignum with
95  ;; high word 0.
96  (tst val (:$ #x80000003))
97  (moveq imm0 (:lsr val (:$ arm::fixnumshift)))
98  (beq @word-set-loop)
99  (extract-typecode imm0 val)
100  (cmp imm0 (:$ arm::subtag-bignum))
101  (bne @bad)
102  (getvheader imm0 val)
103  (header-size imm0 imm0)
104  (cmp imm0 (:$ 1))
105  (bne @u32-two-digit)
106  (ldr imm0 (:@ val (:$ arm::misc-data-offset)))
107  (cmp imm0 (:$ 0))
108  (bmi @bad)
109  (b @word-set-loop)
110  @u32-two-digit
111  (cmp imm0 (:$ 2))
112  (ldr imm0 (:@ val (:$ (+ arm::misc-data-offset 4))))
113  (bne @bad)
114  (cmp imm0 (:$ 0))
115  (ldr imm0 (:@ val (:$ arm::misc-data-offset))) 
116  (bne @bad)
117  (b @word-set-loop)
118  @s32
119  ;; A fixnum or a 1-digit bignum.
120  (ands imm0 val (:$ arm::tag-mask))
121  (moveq imm0 (:asr val (:$ arm::fixnumshift)))
122  (beq @word-set-loop)
123  (cmp imm0 (:$ arm::tag-misc))
124  (ldrbeq imm0 (:@ val (:$ arm::misc-subtag-offset)))
125  (cmp imm0 (:$ arm::subtag-bignum))
126  (bne @bad)
127  (getvheader imm0 val)
128  (header-size imm0 imm0)
129  (cmp imm0 (:$ 1))
130  (ldr imm0 (:@ val (:$ arm::misc-data-offset)))
131  (bne @bad)
132  @word-set-loop
133  (subs temp1 temp1 '1)
134  (str imm0 (:@ miscobj imm1))
135  (add imm1 imm1 '1)
136  (bne @word-set-loop)
137  (return-lisp-frame)
138  @string
139  (extract-lowbyte imm0 val)
140  (cmp imm0 (:$ arm::subtag-character))
141  (mov imm0 (:lsr val (:$ arm::charcode-shift)))
142  (beq @word-set-loop)
143  @bad
144  (mov arg_x  '#.$xnotelt)
145  (set-nargs 3)
146  (sploadlr .SPksignalerr)
147  (blx lr)
148  @fixnum
149  (tst val (:$ arm::fixnum-mask))
150  (unbox-fixnum imm0 val)
151  (beq @word-set-loop)
152  (b @bad)
153  @single-float-vector
154  (extract-subtag imm0 val)
155  (cmp imm0 (:$ arm::subtag-single-float))
156  (bne @bad)
157  (ldr imm0 (:@ val (:$ arm::misc-data-offset)))
158  (b @word-set-loop)
159  @u16
160  (mov imm0 (:lsl val (:$ (- 16 arm::fixnumshift))))
161  (mov imm0 (:lsr imm0 (:$ 16)))
162  (cmp val (:lsl imm0 (:$ arm::fixnumshift)))
163  (bne @bad)
164  @set16
165  (orr imm0 imm0 (:lsl imm0 (:$ 16)))
166  (add imm2 temp1 '1)
167  (mov temp1 (:$ (- arm::fixnumone)))
168  (and temp1 temp1 (:lsr imm2 (:$ 1)))
169  (b @word-set-loop)
170  @s16
171  (mov imm0 (:lsl val (:$ (- 16 arm::fixnumshift))))
172  (mov imm0 (:asr imm0 (:$ 16)))
173  (cmp val (:lsl imm0 (:$ arm::fixnumshift)))
174  (bne @bad)
175  (b @set16)
176  @u8
177  (mov imm0 (:lsl val (:$ (- 24 arm::fixnumshift))))
178  (mov imm0 (:lsr imm0 (:$ 24)))
179  (cmp val (:lsl imm0 (:$ arm::fixnumshift))) 
180  (bne @bad)
181  @set8
182  (orr imm0 imm0 (:lsl imm0 (:$ 8)))
183  (orr imm0 imm0 (:lsl imm0 (:$ 16)))
184  (unbox-fixnum imm2 temp1)
185  (add imm2 imm2 (:$ 3))
186  (mov imm2 (:lsr imm2 (:$ 2)))
187  (box-fixnum temp1 imm2)
188  (b @word-set-loop)
189  @s8
190  (mov imm0 (:lsl val (:$ (- 24 arm::fixnumshift))))
191  (mov imm0 (:asr imm0 (:$ 24)))
192  (cmp val (:lsl imm0 (:$ arm::fixnumshift))) 
193  (beq @set8)
194  (b @bad)
195  @string8
196  (extract-lowbyte imm0 val)
197  (cmp imm0 (:$ arm::subtag-character))
198  (mov imm0 (:lsr imm0 (:$ arm::charcode-shift)))
199  (bne @bad)
200  (cmp imm0 (:$ #xff))
201  (bls @set8)
202  (b @bad)
203  @bit-vector
204  (cmp val '1)
205  (moveq imm0 (:$ -1))
206  (movne imm0 (:$ 0))
207  (bhi @bad)
208  (unbox-fixnum imm2 temp1)
209  (add imm2 imm2 (:$ 31))
210  (mov imm2 (:lsr imm2 (:$ 5)))
211  (box-fixnum temp1 imm2)
212  (b @word-set-loop)
213  @double-float-vector
214  (extract-typecode imm0 val)
215  (cmp imm0 (:$ arm::subtag-double-float))
216  (bne @bad)
217  (ldrd imm0 (:@ val (:$ arm::double-float.value)))
218  (mov imm2 (:$ arm::misc-dfloat-offset))
219  @double-float-loop
220  (subs temp1 temp1 '1)
221  (strd imm0 (:@ miscobj imm2))
222  (add imm2 imm2 (:$ 8))
223  (bne @double-float-loop)
224  (return-lisp-frame imm0))
225
226
227
228
229
230;;; argument is a vector header or an array header.  Or else.
231(defarmlapfunction %array-header-data-and-offset ((a arg_z))
232  (let ((offset arg_y)
233        (disp arg_x)
234        (temp temp0))
235    (mov offset (:$ 0))
236    (mov temp a)
237    @loop
238    (ldr a (:@ temp (:$ target::arrayH.data-vector)))
239    (ldrb imm0 (:@ a (:$ target::misc-subtag-offset)))
240    (cmp imm0 (:$ target::subtag-vectorH))
241    (ldr disp (:@ temp (:$ target::arrayH.displacement)))
242    (mov temp a)
243    (add offset offset disp)
244    (ble  @loop)
245    (mov temp0 vsp)
246    (vpush1 a)
247    (vpush1 offset)
248    (set-nargs 2)
249    (spjump .SPvalues)))
250
251(defarmlapfunction %boole-clr ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
252  (vpop1 temp0)
253  (mov imm2 (:$ arm::misc-data-offset))
254  (mov imm0 (:$ 0))
255  (b @test)
256  @loop
257  (str imm0 (:@ dest imm2))
258  (add imm2 imm2 (:$ 4))
259  @test
260  (subs temp0 temp0 '1)
261  (bpl @loop)
262  (bx lr))
263
264(defarmlapfunction %boole-set ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
265  (vpop1 temp0)
266  (mov imm2 (:$ arm::misc-data-offset))
267  (mov imm0 (:$ -1))
268  (b @test)
269  @loop
270  (str imm0 (:@ dest imm2))
271  (add imm2 imm2 (:$ 4))
272  @test
273  (subs temp0 temp0 '1)
274  (bpl @loop)
275  (bx lr))
276
277(defarmlapfunction %boole-1 ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
278  (vpop1 temp0)
279  (mov imm2 (:$ arm::misc-data-offset))
280  (b @test)
281  @loop
282  (ldr imm0 (:@ b0 imm2))
283  (str imm0 (:@ dest imm2))
284  (add imm2 imm2 (:$ 4))
285  @test
286  (subs temp0 temp0 '1)
287  (bpl @loop)
288  (bx lr))
289
290(defarmlapfunction %boole-2 ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
291  (vpop1 temp0)
292  (mov imm2 (:$ arm::misc-data-offset))
293  (b @test)
294  @loop
295  (ldr imm0 (:@ b1 imm2))
296  (str imm0 (:@ dest imm2))
297  (add imm2 imm2 (:$ 4))
298  @test
299  (subs temp0 temp0 '1)
300  (bpl @loop)
301  (bx lr))
302
303(defarmlapfunction %boole-c1 ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
304  (vpop1 temp0)
305  (mov imm2 (:$ arm::misc-data-offset))
306  (b @test)
307  @loop
308  (ldr imm0 (:@ b0 imm2))
309  (mvn imm0 imm0)
310  (str imm0 (:@ dest imm2))
311  (add imm2 imm2 (:$ 4))
312  @test
313  (subs temp0 temp0 '1)
314  (bpl @loop)
315  (bx lr))
316
317(defarmlapfunction %boole-c2 ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
318  (vpop1 temp0)
319  (mov imm2 (:$ arm::misc-data-offset))
320  (b @test)
321  @loop
322  (ldr imm0 (:@ b1 imm2))
323  (mvn imm0 imm0)
324  (str imm0 (:@ dest imm2))
325  (add imm2 imm2 (:$ 4))
326  @test
327  (subs temp0 temp0 '1)
328  (bpl @loop)
329  (bx lr))
330
331(defarmlapfunction %boole-and ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
332  (vpop1 temp0)
333  (mov imm2 (:$ arm::misc-data-offset))
334  (b @test)
335  @loop
336  (ldr imm0 (:@ b0 imm2))
337  (ldr imm1 (:@ b1 imm2))
338  (and imm0 imm0 imm1)
339  (str imm0 (:@ dest imm2))
340  (add imm2 imm2 (:$ 4))
341  @test
342  (subs temp0 temp0 '1)
343  (bpl @loop)
344  (bx lr))
345
346(defarmlapfunction %boole-ior ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
347  (vpop1 temp0)
348  (mov imm2 (:$ arm::misc-data-offset))
349  (b @test)
350  @loop
351  (ldr imm0 (:@ b0 imm2))
352  (ldr imm1 (:@ b1 imm2))
353  (orr imm0 imm0 imm1)
354  (str imm0 (:@ dest imm2))
355  (add imm2 imm2 (:$ 4))
356  @test
357  (subs temp0 temp0 '1)
358  (bpl @loop)
359  (bx lr))
360
361(defarmlapfunction %boole-xor ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
362  (vpop1 temp0)
363  (mov imm2 (:$ arm::misc-data-offset))
364  (b @test)
365  @loop
366  (ldr imm0 (:@ b0 imm2))
367  (ldr imm1 (:@ b1 imm2))
368  (eor imm0 imm0 imm1)
369  (str imm0 (:@ dest imm2))
370  (add imm2 imm2 (:$ 4))
371  @test
372  (subs temp0 temp0 '1)
373  (bpl @loop)
374  (bx lr))
375
376(defarmlapfunction %boole-eqv ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
377  (vpop1 temp0)
378  (mov imm2 (:$ arm::misc-data-offset))
379  (b @test)
380  @loop
381  (ldr imm0 (:@ b0 imm2))
382  (ldr imm1 (:@ b1 imm2))
383  (eor imm0 imm0 imm1)
384  (mvn imm0 imm0)
385  (str imm0 (:@ dest imm2))
386  (add imm2 imm2 (:$ 4))
387  @test
388  (subs temp0 temp0 '1)
389  (bpl @loop)
390  (bx lr))
391
392(defarmlapfunction %boole-nand ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
393  (vpop1 temp0)
394  (mov imm2 (:$ arm::misc-data-offset))
395  (b @test)
396  @loop
397  (ldr imm0 (:@ b0 imm2))
398  (ldr imm1 (:@ b1 imm2))
399  (and imm0 imm0 imm1)
400  (mvn imm0 imm0)
401  (str imm0 (:@ dest imm2))
402  (add imm2 imm2 (:$ 4))
403  @test
404  (subs temp0 temp0 '1)
405  (bpl @loop)
406  (bx lr))
407
408(defarmlapfunction %boole-nor ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
409  (vpop1 temp0)
410  (mov imm2 (:$ arm::misc-data-offset))
411  (b @test)
412  @loop
413  (ldr imm0 (:@ b0 imm2))
414  (ldr imm1 (:@ b1 imm2))
415  (orr imm0 imm0 imm1)
416  (mvn imm0 imm0)
417  (str imm0 (:@ dest imm2))
418  (add imm2 imm2 (:$ 4))
419  @test
420  (subs temp0 temp0 '1)
421  (bpl @loop)
422  (bx lr))
423
424(defarmlapfunction %boole-andc1 ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
425  (vpop1 temp0)
426  (mov imm2 (:$ arm::misc-data-offset))
427  (b @test)
428  @loop
429  (ldr imm0 (:@ b0 imm2))
430  (ldr imm1 (:@ b1 imm2))
431  (bic imm0 imm1 imm0)
432  (str imm0 (:@ dest imm2))
433  (add imm2 imm2 (:$ 4))
434  @test
435  (subs temp0 temp0 '1)
436  (bpl @loop)
437  (bx lr))
438
439(defarmlapfunction %boole-andc2 ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
440  (vpop1 temp0)
441  (mov imm2 (:$ arm::misc-data-offset))
442  (b @test)
443  @loop
444  (ldr imm0 (:@ b0 imm2))
445  (ldr imm1 (:@ b1 imm2))
446  (bic imm0 imm0 imm1)
447  (str imm0 (:@ dest imm2))
448  (add imm2 imm2 (:$ 4))
449  @test
450  (subs temp0 temp0 '1)
451  (bpl @loop)
452  (bx lr))
453
454(defarmlapfunction %boole-orc1 ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
455  (vpop1 temp0)
456  (mov imm2 (:$ arm::misc-data-offset))
457  (b @test)
458  @loop
459  (ldr imm0 (:@ b0 imm2))
460  (ldr imm1 (:@ b1 imm2))
461  (mvn imm0 imm0)
462  (orr imm0 imm0 imm1)
463  (str imm0 (:@ dest imm2))
464  (add imm2 imm2 (:$ 4))
465  @test
466  (subs temp0 temp0 '1)
467  (bpl @loop)
468  (bx lr))
469
470(defarmlapfunction %boole-orc2 ((len 0) (b0 arg_x) (b1 arg_y) (dest arg_z))
471  (vpop1 temp0)
472  (mov imm2 (:$ arm::misc-data-offset))
473  (b @test)
474  @loop
475  (ldr imm0 (:@ b0 imm2))
476  (ldr imm1 (:@ b1 imm2))
477  (mvn imm1 imm1)
478  (orr imm0 imm0 imm1)
479  (str imm0 (:@ dest imm2))
480  (add imm2 imm2 (:$ 4))
481  @test
482  (subs temp0 temp0 '1)
483  (bpl @loop)
484  (bx lr))
485
486(defparameter *simple-bit-boole-functions* ())
487
488(setq *simple-bit-boole-functions*
489      (vector
490       #'%boole-clr
491       #'%boole-set
492       #'%boole-1
493       #'%boole-2
494       #'%boole-c1
495       #'%boole-c2
496       #'%boole-and
497       #'%boole-ior
498       #'%boole-xor
499       #'%boole-eqv
500       #'%boole-nand
501       #'%boole-nor
502       #'%boole-andc1
503       #'%boole-andc2
504       #'%boole-orc1
505       #'%boole-orc2))
506
507(defun %simple-bit-boole (op b1 b2 result)
508  (funcall (svref *simple-bit-boole-functions* op)
509           (ash (the fixnum (+ (length result) 31)) -5)
510           b1
511           b2
512           result))
513
514
515(defarmlapfunction %aref2 ((array arg_x) (i arg_y) (j arg_z))
516  (check-nargs 3)
517  (spjump .SParef2))
518
519(defarmlapfunction %aref3 ((array 0) (i arg_x) (j arg_y) (k arg_z))
520  (check-nargs 4)
521  (vpop1 temp0)
522  (spjump .SParef3))
523
524
525(defarmlapfunction %aset2 ((array 0) (i arg_x) (j arg_y) (newval arg_z))
526  (check-nargs 4)
527  (vpop1 temp0)
528  (spjump .SPaset2))
529
530(defarmlapfunction %aset3 ((array #.target::node-size) (i 0) (j arg_x) (k arg_y)  (newval arg_z))
531  (check-nargs 5)
532  (vpop1 temp0)
533  (vpop1 temp1)
534  (spjump .SPaset3))
535 
536
Note: See TracBrowser for help on using the repository browser.