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

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

New Linux ARM binaries.

The image and FASL versions changed on the ARM, but (if I did it right)
not on other platforms.

(The image and FASL versions are now architecture-specific. This may
make it somewhat easier and less disruptive to change them, since the
motivation for such a change is often also architecture-specific.)
The FASL and current image version are defined (in the "TARGET" package)
in the architecture-specific *-arch.lisp files; the min, max, and current
image versions are defined in the *constants*.h file for the architecture.

Most of the changes are ARM-specific.

Each TCR now contains a 256-word table at byte offset 256. (We've
been using about 168 bytes in the TCR, so there are still 88 bytes/22
words left for expansion.) The table is initialized at TCR-creation
time to contain the absolute addresses of the subprims (there are
currently around 130 defined); we try otherwise not to reference
subprims by absolute address. Jumping to a subprim is:

(ldr pc (:@ rcontext (:$ offset-of-subprim-in-tcr-table)))

and calling one involves loading its address from that table into a
register and doing (blx reg). We canonically use LR as the register,
since it's going to be clobbered by the blx anyway and there doesn't
seem to be a performance hazard there. The old scheme (which involved
using BA and BLA pseudoinstructions to jump to/call a hidden jump table
at the end of the function) is no longer supported.

ARM Subprims no longer need to be aligned (on anything more than an
instruction boundary.) Some remnants of the consequences of an old
scheme (where subprims had to "fit" in small regions and sometimes
had to jump out of line if they would overflow that region's bounds)
still remain, but we can repair that (and it'll be a bit more straightforward
to add new ARM subprims.) We no longer care (much) about where subprims
are mapped in memory, and don't have to bias suprimitive addresses by
a platform-specific constant (and have to figure out whether or not we've
already done so) on (e.g.) Android.

Rather than setting the first element (fn.entrypoint) of a
newly-created function to the (absolute) address of a subprim that updates
that entrypoint on the first call, we use a little LAP function to correct
the address before the function can be called.

Non-function objects that can be stored in symbols' function cells
(the UNDEFINED-FUNCTION object, the things that encapsulate
special-operator names and global macro-functions) need to be
structured like FUNCTIONS: the need to have a word-aligned entrypoint
in element 0 that tracks the CODE-VECTOR object in element 1. We
don't want these things to be of type FUNCTION, but do want the GC to
adjust the entrypoint if the codevector moves. We've been essentially
out of GVECTOR subtags on 32-bit platforms, largely because of the
constraints that vector/array subtags must be greater than other
subtags and numeric types be less. The first constraint is probably
reasonable, but the second isn't: other typecodes (tag-list, etc) may
be less than the maximum numeric typecode, so tests like NUMBERP can't
reliably involve a simple comparison. (As long as a mask of all
numeric typecodes will fit in a machine word/FIXNUM, a simple LOGBITP
test can be used instead.) Removed all portable and ARM-specific code
that made assumptions about numeric typecode ordering, made a few more
gvector typecodes available, and used one of them to define a new
"pseudofunction" type. Made the GC update the entrypoints of
pseudofunctions and used them for the undefined-function object and
for the function cells of macros/special-operators.

Since we don't need the subprim jump table at the end of each function
anymore, we can more easily revive the idea of embedded pc-relative
constant data ("constant pools") and initialize FPRs from constant
data, avoiding most remaining traffic between FPRs and GPRs.

I've had a fairly-reproducible cache-coherency problem: on the first
GC in the cold load, the thread misbehaves mysteriously when it
resumes. The GC tries to synchronize the I and D caches on the entire
range of addresses that may contain newly-moved code-vectors. I'm not
at all sure why, but walking that range and flushing the cache for
each code-vector individually seems to avoid the problem (and may actually
be faster.)

Fix ticket:894

Fixed a few typos in error messages/comments/etc.

I -think- that the non-ARM-specific changes (how FASL/image versions are
defined) should bootstrap cleanly, but won't know for sure until this is
committed. (I imagine that the buildbot will complain if not.)

File size: 36.6 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;;; level-0;ARM;arm-misc.lisp
18
19
20(in-package "CCL")
21
22 
23;;; Copy N bytes from pointer src, starting at byte offset src-offset,
24;;; to ivector dest, starting at offset dest-offset.
25;;; It's fine to leave this in lap.
26;;; Depending on alignment, it might make sense to move more than
27;;; a byte at a time.
28;;; Does no arg checking of any kind.  Really.
29
30
31(defun %copy-ptr-to-ivector (src src-byte-offset dest dest-byte-offset nbytes)
32  (declare (fixnum src-byte-offset dest-byte-offset nbytes)
33           (optimize (speed 3) (safety 0)))
34  (let* ((ptr-align (logand 7 (%ptr-to-int src))))
35    (declare (type (mod 8) ptr-align))
36    (if (and (>= nbytes 32)
37             (= 0 (logand nbytes 3))
38             (= 0 (logand dest-byte-offset 3))
39             (= 0 (logand (the fixnum (+ ptr-align src-byte-offset)) 3)))
40      (%copy-ptr-to-ivector-32bit src src-byte-offset dest dest-byte-offset nbytes)
41      (%copy-ptr-to-ivector-8bit src src-byte-offset dest dest-byte-offset nbytes))
42    dest))
43           
44(defarmlapfunction %copy-ptr-to-ivector-8bit ((src (* 1 arm::node-size) )
45                                               (src-byte-offset 0) 
46                                               (dest arg_x)
47                                               (dest-byte-offset arg_y)
48                                               (nbytes arg_z))
49  (let ((src-reg imm0)
50        (src-byteptr temp2)
51        (src-node-reg temp0)
52        (dest-byteptr imm2)
53        (val imm1)
54        (node-temp temp1))
55    (cmp nbytes (:$ 0))
56    (ldr src-node-reg (:@ vsp (:$ src)))
57    (macptr-ptr src-reg src-node-reg)
58    (ldr src-byteptr (:@ vsp (:$ src-byte-offset)))
59    (add src-reg src-reg (:asr src-byteptr (:$ arm::fixnumshift)))
60    (unbox-fixnum dest-byteptr dest-byte-offset)
61    (add dest-byteptr dest-byteptr (:$ arm::misc-data-offset))
62    (b @test)
63    @loop
64    (subs nbytes nbytes '1)
65    (ldrb val (:@+ src-reg (:$ 1)))
66    (strb val (:@ dest dest-byteptr))
67    (add dest-byteptr dest-byteptr (:$ 1))
68    @test
69    (bne  @loop)
70    (mov arg_z dest)
71    (add vsp vsp '2)
72    (bx lr)))
73
74;;; Everything's aligned OK and NBYTES is a multiple of 4.
75(defarmlapfunction %copy-ptr-to-ivector-32bit ((src (* 1 arm::node-size) )
76                                               (src-byte-offset 0) 
77                                               (dest arg_x)
78                                               (dest-byte-offset arg_y)
79                                               (nbytes arg_z))
80  (add imm1 vsp (:$ (* 2 arm::node-size)))
81  (build-lisp-frame imm0 imm1)
82  (add lr dest (:$ arm::misc-data-offset))
83  (add lr lr (:asr dest-byte-offset (:$ arm::fixnumshift)))
84  (ldr temp0 (:@ vsp (:$ src)))
85  (ldr imm1 (:@ vsp (:$ src-byte-offset)))
86  (macptr-ptr imm0 temp0)
87  (add imm0 imm0 (:asr imm1 (:$ arm::fixnumshift)))
88  (b @test32)
89  @loop32
90  (fldmias s0 (:! imm0) 8)
91  (fstmias s0 (:! lr) 8)
92  (sub nbytes nbytes '32)
93  @test32
94  (cmp nbytes '32)
95  (bge @loop32)
96  (add pc pc (:asr nbytes (:$ arm::fixnumshift)))
97  (nop)
98  (b @0)
99  (b @4)
100  (b @8)
101  (b @12)
102  (b @16)
103  (b @20)
104  (b @24)
105  (b @28)
106  (nop)
107  @0
108  (mov arg_z dest)
109  (restore-lisp-frame imm0)
110  (bx lr)
111  @4
112  (flds s0 (:@ imm0 (:$ 0)))
113  (fsts s0 (:@ lr (:$ 0)))
114  (b @0)
115  @8
116  (fldmias s0 imm0 2)
117  (fstmias s0 lr 2)
118  (b @0)
119  @12
120  (fldmias s0 imm0 3)
121  (fstmias s0 lr 3)
122  (b @0)
123  @16
124  (fldmias s0 imm0 4)
125  (fstmias s0 lr 4)
126  (b @0)
127  @20
128  (fldmias s0 imm0 5)
129  (fstmias s0 lr 5)
130  (b @0)
131  @24
132  (fldmias s0 imm0 6)
133  (fstmias s0 lr 6)
134  (b @0)
135  @28
136  (fldmias s0 imm0 7)
137  (fstmias s0 lr 7)
138  (b @0))
139 
140
141(defun %copy-ivector-to-ptr (src src-byte-offset dest dest-byte-offset nbytes)
142  (declare (fixnum src-byte-offset dest-byte-offset nbytes)
143           (optimize (speed 3) (safety 0)))
144  (let* ((ptr-align (logand (the (unsigned-byte 32)(%ptr-to-int dest)) 7)))
145    (declare (type (mod 8) ptr-align))
146    (if (or (< nbytes 32)
147            (not (= 0 (logand nbytes 3)))
148            (not (= 0 (logand src-byte-offset 3)))
149            (not (= 0 (logand (the fixnum (+ ptr-align dest-byte-offset)) 3))))
150      (%copy-ivector-to-ptr-8bit src src-byte-offset dest dest-byte-offset nbytes)
151      (%copy-ivector-to-ptr-32bit src src-byte-offset dest dest-byte-offset nbytes))
152    dest))
153
154(defarmlapfunction %copy-ivector-to-ptr-8bit ((src (* 1 arm::node-size))
155                                              (src-byte-offset 0)
156                                              (dest arg_x)
157                                              (dest-byte-offset arg_y)
158                                              (nbytes arg_z))
159  (ldr temp0 (:@ vsp (:$ src)))
160  (cmp nbytes (:$ 0))
161  (ldr imm0 (:@ vsp (:$ src-byte-offset)))
162  (unbox-fixnum imm0 imm0)
163  (add imm0 imm0 (:$ arm::misc-data-offset))
164  (macptr-ptr imm1 dest)
165  (add imm1 imm1 (:asr dest-byte-offset (:$ arm::fixnumshift)))
166  (b @test)
167  @loop
168  (subs nbytes nbytes '1)
169  (ldrb imm2 (:@ temp0 imm0))
170  (add imm0 imm0 (:$ 1))
171  (strb imm2 (:@+ imm1 (:$ 1)))
172  @test
173  (bne @loop)
174  (mov arg_z dest)
175  (add vsp vsp '2)
176  (bx lr))
177
178;;; Everything's aligned OK and NBYTES is a multiple of 4.
179(defarmlapfunction %copy-ivector-to-ptr-32bit ((src (* 1 arm::node-size) )
180                                               (src-byte-offset 0) 
181                                               (dest arg_x)
182                                               (dest-byte-offset arg_y)
183                                               (nbytes arg_z))
184  (add imm1 vsp (:$ (* 2 arm::node-size)))
185  (build-lisp-frame imm0 imm1)
186  (ldr temp0 (:@ vsp (:$ src)))
187  (ldr imm1 (:@ vsp (:$ src-byte-offset)))
188  (add lr temp0 (:$ arm::misc-data-offset))
189  (add lr lr (:asr imm1 (:$ arm::fixnumshift)))
190  (macptr-ptr imm0 dest)
191  (add imm0 imm0 (:asr dest-byte-offset (:$ arm::fixnumshift)))
192  (b @test32)
193  @loop32
194  (fldmias s0 (:! lr) 8)
195  (fstmias s0 (:! imm0) 8)
196  (sub nbytes nbytes '32)
197  @test32
198  (cmp nbytes '32)
199  (bge @loop32)
200  (add pc pc (:asr nbytes (:$ arm::fixnumshift)))
201  (nop)
202  (b @0)
203  (b @4)
204  (b @8)
205  (b @12)
206  (b @16)
207  (b @20)
208  (b @24)
209  (b @28)
210  (nop)
211  @0
212  (mov arg_z dest)
213  (restore-lisp-frame imm0)
214  (bx lr)
215  @4
216  (flds s0 (:@ lr (:$ 0)))
217  (fsts s0 (:@ imm0 (:$ 0)))
218  (b @0)
219  @8
220  (fldmias s0 lr 2)
221  (fstmias s0 imm0 2)
222  (b @0)
223  @12
224  (fldmias s0 lr 3)
225  (fstmias s0 imm0 3)
226  (b @0)
227  @16
228  (fldmias s0 lr 4)
229  (fstmias s0 imm0 4)
230  (b @0)
231  @20
232  (fldmias s0 lr 5)
233  (fstmias s0 imm0 5)
234  (b @0)
235  @24
236  (fldmias s0 lr 6)
237  (fstmias s0 imm0 6)
238  (b @0)
239  @28
240  (fldmias s0 lr 7)
241  (fstmias s0 imm0 7)
242  (b @0))
243
244
245(defun %copy-ivector-to-ivector (src src-byte-offset dest dest-byte-offset nbytes)
246  (declare (fixnum src-byte-offset dest-byte-offset nbytes))
247  (if (or (not (eq src dest))
248          (< dest-byte-offset src-byte-offset)
249          (>= dest-byte-offset (the fixnum (+ src-byte-offset nbytes))))
250    (%copy-ivector-to-ivector-postincrement src src-byte-offset dest dest-byte-offset nbytes)
251    (if (and (eq src dest)
252             (eql src-byte-offset dest-byte-offset))
253      dest
254      (%copy-ivector-to-ivector-predecrement src
255                                             (the fixnum (+ src-byte-offset nbytes))
256                                             dest
257                                             (the fixnum (+ dest-byte-offset nbytes))
258                                             nbytes)))
259  dest)
260
261(defun %copy-ivector-to-ivector-postincrement (src src-byte-offset dest dest-byte-offset nbytes)
262  (declare (fixnum src-byte-offset dest-byte-offset nbytes))
263 
264  (cond ((or (< nbytes 8)
265             (not (= (logand src-byte-offset 3)
266                     (logand dest-byte-offset 3))))
267         (%copy-ivector-to-ivector-postincrement-8bit src src-byte-offset dest dest-byte-offset nbytes))
268        (t
269         (let* ((prefix-size (- 4 (logand src-byte-offset 3))))
270           (declare (fixnum prefix-size))
271           (unless (= 4 prefix-size)
272             (%copy-ivector-to-ivector-postincrement-8bit src src-byte-offset dest dest-byte-offset prefix-size)
273             (incf src-byte-offset prefix-size)
274             (incf dest-byte-offset prefix-size)
275             (decf nbytes prefix-size)))
276         (let* ((tail-size (logand nbytes 3))
277                (fullword-size (- nbytes tail-size)))
278           (declare (fixnum tail-size fullword-size))
279           (unless (zerop fullword-size)
280             (%copy-ivector-to-ivector-postincrement-32bit src src-byte-offset dest dest-byte-offset fullword-size))
281           (unless (zerop tail-size)
282             (%copy-ivector-to-ivector-postincrement-8bit src (the fixnum (+ src-byte-offset fullword-size)) dest (the fixnum (+ dest-byte-offset fullword-size)) tail-size))))))
283
284(defun %copy-ivector-to-ivector-predecrement (src src-byte-offset dest dest-byte-offset nbytes)
285  (declare (fixnum src-byte-offset dest-byte-offset nbytes))
286  (cond ((or (< nbytes 8)
287             (not (= (logand src-byte-offset 3)
288                     (logand dest-byte-offset 3))))
289         (%copy-ivector-to-ivector-predecrement-8bit src src-byte-offset dest dest-byte-offset nbytes))
290    (t
291      (let* ((suffix-size (logand src-byte-offset 3)))
292        (declare (fixnum suffix-size))
293        (unless (zerop suffix-size)
294          (%copy-ivector-to-ivector-predecrement-8bit src src-byte-offset dest dest-byte-offset suffix-size)
295          (decf src-byte-offset suffix-size)
296          (decf dest-byte-offset suffix-size)
297          (decf nbytes suffix-size)))
298      (let* ((head-size (logand nbytes 3))
299             (fullword-size (- nbytes head-size)))
300        (declare (fixnum head-size fullword-size))
301        (unless (zerop fullword-size)
302          (%copy-ivector-to-ivector-predecrement-32bit src src-byte-offset dest dest-byte-offset fullword-size))
303        (unless (zerop head-size)
304          (%copy-ivector-to-ivector-predecrement-8bit src (the fixnum (- src-byte-offset fullword-size)) dest (the fixnum (- dest-byte-offset fullword-size)) head-size))))
305))
306
307(defarmlapfunction %copy-ivector-to-ivector-postincrement-8bit ((src 4) 
308                                                                (src-byte-offset 0) 
309                                                                (dest arg_x)
310                                                                (dest-byte-offset arg_y)
311                                                                (nbytes arg_z))
312  (let ((rsrc temp0)
313        (scaled-src-idx imm1)
314        (scaled-dest-idx imm2)
315        (val imm0))
316    (cmp nbytes (:$ 0))
317    (vpop1 scaled-src-idx)
318    (mov scaled-src-idx (:lsr scaled-src-idx (:$ arm::fixnumshift)))
319    (add scaled-src-idx scaled-src-idx (:$ arm::misc-data-offset))
320    (mov scaled-dest-idx (:lsr dest-byte-offset (:$ arm::fixnumshift)))
321    (add scaled-dest-idx scaled-dest-idx (:$ arm::misc-data-offset))   
322    (vpop1 rsrc)
323    (b @test)
324    @loop
325    (subs nbytes nbytes '1)
326    (ldrb val (:@ rsrc scaled-src-idx))
327    (add scaled-src-idx scaled-src-idx (:$ 1))
328    (strb val (:@ dest scaled-dest-idx))
329    (add scaled-dest-idx scaled-dest-idx (:$ 1))
330    @test
331    (bne @loop)
332    (mov arg_z dest)
333    (bx lr)))
334
335(defarmlapfunction %copy-ivector-to-ivector-postincrement-32bit ((src 4) 
336                                                                 (src-byte-offset 0) 
337                                                                 (dest arg_x)
338                                                                 (dest-byte-offset arg_y)
339                                                                 (nbytes arg_z))
340  (let ((rsrc temp0)
341        (scaled-src-idx imm1)
342        (scaled-dest-idx imm2)
343        (val imm0))
344    (cmp nbytes '32)
345    (vpop1 scaled-src-idx)
346    (mov scaled-src-idx (:lsr scaled-src-idx (:$ arm::fixnumshift)))
347    (add scaled-src-idx scaled-src-idx (:$ arm::misc-data-offset))
348    (mov scaled-dest-idx (:lsr dest-byte-offset (:$ arm::fixnumshift)))
349    (add scaled-dest-idx scaled-dest-idx (:$ arm::misc-data-offset))   
350    (vpop1 rsrc)
351    (build-lisp-frame imm0)             
352    (b @test)
353    @loop
354    (sub nbytes nbytes '32)
355    (cmp nbytes '32)
356    (add lr rsrc scaled-src-idx)
357    (fldmias s0 lr 8)
358    (add scaled-src-idx scaled-src-idx (:$ 32))
359    (add lr dest scaled-dest-idx)
360    (fstmias s0 lr 8)
361    (add scaled-dest-idx scaled-dest-idx (:$ 32))
362    @test
363    (bge @loop)
364    (add pc pc (:asr nbytes (:$ arm::fixnumshift)))
365    (nop)
366    (b @0)
367    (b @4)
368    (b @8)
369    (b @12)
370    (b @16)
371    (b @20)
372    (b @24)
373    (b @28)
374    (nop)
375    @4
376    (ldr val (:@ rsrc scaled-src-idx))
377    (str val (:@ dest scaled-dest-idx))
378    (b @0)
379    @8
380    (add lr rsrc scaled-src-idx)
381    (fldmias s0 lr 2)
382    (add lr dest scaled-dest-idx)
383    (fstmias s0 lr 2)
384    (b @0)
385    @12
386    (add lr rsrc scaled-src-idx)
387    (fldmias s0 lr 3)
388    (add lr dest scaled-dest-idx)
389    (fstmias s0 lr 3)
390    (b @0)
391    @16
392    (add lr rsrc scaled-src-idx)
393    (fldmias s0 lr 4)
394    (add lr dest scaled-dest-idx)
395    (fstmias s0 lr 4)
396    (b @0)
397    @20
398    (add lr rsrc scaled-src-idx)
399    (fldmias s0 lr 5)
400    (add lr dest scaled-dest-idx)
401    (fstmias s0 lr 5)
402    (b @0)
403    @24
404    (add lr rsrc scaled-src-idx)
405    (fldmias s0 lr 6)
406    (add lr dest scaled-dest-idx)
407    (fstmias s0 lr 6)
408    (b @0)
409    @28
410    (add lr rsrc scaled-src-idx)
411    (fldmias s0 lr 7)
412    (add lr dest scaled-dest-idx)
413    (fstmias s0 lr 7)
414    @0
415    (mov arg_z dest)
416    (restore-lisp-frame imm0)
417    (bx lr)))
418
419(defarmlapfunction %copy-ivector-to-ivector-predecrement-8bit ((src 4) 
420                                                               (src-byte-offset 0) 
421                                                               (dest arg_x)
422                                                               (dest-byte-offset arg_y)
423                                                               (nbytes arg_z))
424  (let ((rsrc temp0)
425        (scaled-src-idx imm1)
426        (scaled-dest-idx imm2)
427        (val imm0))
428    (cmp nbytes (:$ 0))
429    (vpop1 scaled-src-idx)
430    (mov scaled-src-idx (:lsr scaled-src-idx (:$ arm::fixnumshift)))
431    (add scaled-src-idx scaled-src-idx (:$ arm::misc-data-offset))
432    (mov scaled-dest-idx (:lsr dest-byte-offset (:$ arm::fixnumshift)))
433    (add scaled-dest-idx scaled-dest-idx (:$ arm::misc-data-offset))   
434    (vpop1 rsrc)
435    (b @test)
436    @loop
437    (sub scaled-src-idx scaled-src-idx (:$ 1))
438    (sub scaled-dest-idx scaled-dest-idx (:$ 1))
439    (subs nbytes nbytes '1)
440    (ldrb val (:@ rsrc scaled-src-idx))
441    (strb val (:@ dest scaled-dest-idx))
442    @test
443    (bne @loop)
444    (mov arg_z dest)
445    (bx lr)))
446
447(defarmlapfunction %copy-ivector-to-ivector-predecrement-32bit ((src 4) 
448                                                                (src-byte-offset 0) 
449                                                                (dest arg_x)
450                                                                (dest-byte-offset arg_y)
451                                                                (nbytes arg_z))
452  (let ((rsrc temp0)
453        (scaled-src-idx imm1)
454        (scaled-dest-idx imm2)
455        (val imm0))
456    (cmp nbytes (:$ 32))
457    (vpop1 scaled-src-idx)
458    (mov scaled-src-idx (:lsr scaled-src-idx (:$ arm::fixnumshift)))
459    (add scaled-src-idx scaled-src-idx (:$ arm::misc-data-offset))
460    (mov scaled-dest-idx (:lsr dest-byte-offset (:$ arm::fixnumshift)))
461    (add scaled-dest-idx scaled-dest-idx (:$ arm::misc-data-offset))   
462    (vpop1 rsrc)
463    (build-lisp-frame imm0)             
464    (b @test)
465    @loop
466    (sub scaled-src-idx scaled-src-idx (:$ 32))
467    (sub scaled-dest-idx scaled-dest-idx (:$ 32))
468    (sub nbytes nbytes '32)
469    (cmp nbytes '32)
470    (add lr rsrc scaled-src-idx)
471    (fldmias s0 lr 8)
472    (add lr dest scaled-dest-idx)
473    (fstmias s0 lr 8)
474    @test
475    (bge @loop)
476    (sub scaled-src-idx scaled-src-idx (:asr nbytes (:$ arm::fixnumshift)))
477    (sub scaled-dest-idx scaled-dest-idx (:asr nbytes (:$ arm::fixnumshift)))
478    (add pc pc (:asr nbytes (:$ arm::fixnumshift)))
479    (nop)
480    (b @0)
481    (b @4)
482    (b @8)
483    (b @12)
484    (b @16)
485    (b @20)
486    (b @24)
487    (b @28)
488    (nop)
489    @4
490    (ldr val (:@ rsrc scaled-src-idx))
491    (str val (:@ dest scaled-dest-idx))
492    (b @0)
493    @8
494    (add lr rsrc scaled-src-idx)
495    (fldmias s0 lr 2)
496    (add lr dest scaled-dest-idx)
497    (fstmias s0 lr 2)
498    (b @0)
499    @12
500    (add lr rsrc scaled-src-idx)
501    (fldmias s0 lr 3)
502    (add lr dest scaled-dest-idx)
503    (fstmias s0 lr 3)
504    (b @0)
505    @16
506    (add lr rsrc scaled-src-idx)
507    (fldmias s0 lr 4)
508    (add lr dest scaled-dest-idx)
509    (fstmias s0 lr 4)
510    (b @0)
511    @20
512    (add lr rsrc scaled-src-idx)
513    (fldmias s0 lr 5)
514    (add lr dest scaled-dest-idx)
515    (fstmias s0 lr 5)
516    (b @0)
517    @24
518    (add lr rsrc scaled-src-idx)
519    (fldmias s0 lr 6)
520    (add lr dest scaled-dest-idx)
521    (fstmias s0 lr 6)
522    (b @0)
523    @28
524    (add lr rsrc scaled-src-idx)
525    (fldmias s0 lr 7)
526    (add lr dest scaled-dest-idx)
527    (fstmias s0 lr 7)
528    @0
529    (mov arg_z dest)
530    (restore-lisp-frame imm0)
531    (bx lr)))
532
533;;; Unless we're sure that DEST is newly-created, we have to do this
534;;; in a way that honors the write barrier.
535(defun %copy-gvector-to-gvector (src src-element dest dest-element nelements)
536  (declare (fixnum src-element dest-element nelements)
537           (optimize (speed 3) (safety 0)))
538  (if (or (not (eq src dest))
539          (< dest-element src-element)
540          (>= dest-element (the fixnum (+ src-element nelements))))
541    (do* ()
542         ((<= nelements 0) dest)
543      (setf (%svref dest dest-element)
544            (%svref src src-element))
545      (incf dest-element)
546      (incf src-element)
547      (decf nelements))
548    (do* ((src-element (+ src-element nelements))
549          (dest-element (+ dest-element nelements)))
550         ((<= nelements 0) dest)
551      (declare (fixnum src-element dest-element))
552      (decf src-element)
553      (decf dest-element)
554      (setf (%svref dest dest-element)
555            (%svref src src-element))
556      (decf nelements))))
557 
558 
559
560(defarmlapfunction %heap-bytes-allocated ()
561  (ldr imm2 (:@ rcontext (:$ arm::tcr.last-allocptr)))
562  (ldr imm1 (:@ rcontext (:$ arm::tcr.total-bytes-allocated-high)))
563  (ldr imm0 (:@ rcontext (:$ arm::tcr.total-bytes-allocated-low)))
564  (cmp imm2 (:$ 0))
565  (sub imm2 imm2 allocptr)
566  (beq @go)
567  (cmp allocptr (:$ -8))
568  (beq @go)
569  (adds imm0 imm0 imm2)
570  (adc imm1 imm1 (:$ 0))
571  @go
572  (spjump .SPmakeu64))
573
574
575
576
577(defarmlapfunction values ()
578  (:arglist (&rest values))
579  (vpush-argregs)
580  (add temp0 nargs vsp)
581  (spjump .SPvalues))
582
583;; It would be nice if (%setf-macptr macptr (ash (the fixnum value)
584;; ash::fixnumshift)) would do this inline.
585(defarmlapfunction %setf-macptr-to-object ((macptr arg_y) (object arg_z))
586  (check-nargs 2)
587  (trap-unless-xtype= arg_y arm::subtag-macptr)
588  (str arg_z (:@ arg_y (:$ arm::macptr.address)))
589  (bx lr))
590
591(defarmlapfunction %fixnum-from-macptr ((macptr arg_z))
592  (check-nargs 1)
593  (trap-unless-xtype= arg_z arm::subtag-macptr)
594  (ldr imm0 (:@ arg_z (:$ arm::macptr.address)))
595  (trap-unless-fixnum imm0)
596  (mov arg_z imm0)
597  (bx lr))
598
599(defarmlapfunction %%get-unsigned-longlong ((ptr arg_y) (offset arg_z))
600  (trap-unless-xtype= ptr arm::subtag-macptr)
601  (macptr-ptr imm1 ptr)
602  (unbox-fixnum imm2 offset)
603  (add imm2 imm2 imm1)
604  (ldr imm0 (:@ imm2 (:$ 0)))
605  (ldr imm1 (:@ imm2 (:$ 4)))
606  (spjump .SPmakeu64))
607
608
609
610(defarmlapfunction %%get-signed-longlong ((ptr arg_y) (offset arg_z))
611  (trap-unless-xtype= ptr arm::subtag-macptr)
612  (macptr-ptr imm1 ptr)
613  (unbox-fixnum imm2 offset)
614  (add imm2 imm2 imm1)
615  (ldr imm0 (:@ imm2 (:$ 0)))           ;low
616  (ldr imm1 (:@ imm2 (:$ 4)))           ;high
617  (spjump .SPmakes64))
618
619
620
621(defarmlapfunction %%set-unsigned-longlong ((ptr arg_x)
622                                            (offset arg_y)
623                                            (val arg_z))
624  (build-lisp-frame imm0)
625  (mov fn nfn)
626  (trap-unless-xtype= ptr arm::subtag-macptr) 
627  (sploadlr .SPgetu64)
628  (blx lr)
629  (macptr-ptr imm2 ptr)
630  (add imm2 imm2 (:asr offset (:$ arm::fixnumshift)))
631  (str imm0 (:@ imm2 (:$ 0)))
632  (str imm1 (:@ imm2 (:$ 4)))
633  (return-lisp-frame imm0))
634
635
636
637(defarmlapfunction %%set-signed-longlong ((ptr arg_x)
638                                          (offset arg_y)
639                                          (val arg_z))
640  (build-lisp-frame imm0)
641  (mov fn nfn)
642  (trap-unless-xtype= ptr arm::subtag-macptr)
643  (sploadlr .SPgets64)
644  (blx lr)
645  (macptr-ptr imm2 ptr)
646  (add imm2 imm2 (:asr offset (:$ arm::fixnumshift)))
647  (str imm0 (:@ imm2 (:$ 0)))
648  (str imm1 (:@ imm2 (:$ 4)))
649  (return-lisp-frame imm0))
650
651
652
653(defarmlapfunction interrupt-level ()
654  (ldr arg_z (:@ arm::rcontext (:$ arm::tcr.tlb-pointer)))
655  (ldr arg_z (:@ arg_z (:$ arm::interrupt-level-binding-index)))
656  (bx lr))
657
658
659
660
661(defarmlapfunction set-interrupt-level ((new arg_z))
662  (ldr imm1 (:@ arm::rcontext (:$ arm::tcr.tlb-pointer)))
663  (trap-unless-fixnum new)
664  (str new (:@ imm1 (:$ arm::interrupt-level-binding-index)))
665  (bx lr))
666
667
668
669(defarmlapfunction %current-tcr ()
670  (mov arg_z rcontext)
671  (bx lr))
672
673(defarmlapfunction %tcr-toplevel-function ((tcr arg_z))
674  (check-nargs 1)
675  (cmp tcr arm::rcontext)
676  (mov imm0 vsp)
677  (ldr temp0 (:@ tcr (:$ arm::tcr.vs-area)))
678  (ldr imm1 (:@ temp0 (:$ arm::area.high)))
679  (ldrne imm0 (:@ temp0 (:$ arm::area.active)))
680  (cmp imm1 imm0)
681  (moveq arg_z 'nil)
682  (ldrne arg_z (:@ imm1 (:$ (- arm::node-size))))
683  (bx lr))
684
685(defarmlapfunction %set-tcr-toplevel-function ((tcr arg_y) (fun arg_z))
686  (check-nargs 2)
687  (cmp tcr arm::rcontext)
688  (mov imm0 vsp)
689  (ldr temp0 (:@ tcr (:$ arm::tcr.vs-area)))
690  (ldr imm1 (:@ temp0 (:$ arm::area.high)))
691  (ldrne  imm0 (:@ temp0 (:$ arm::area.active)))
692  (cmp imm1 imm0)
693  (mov imm0 (:$ 0))
694  (push1 imm0 imm1)
695  (streq imm1 (:@ temp0 (:$ arm::area.active)))
696  (streq imm1 (:@ tcr (:$ arm::tcr.save-vsp)))
697  (str fun (:@ imm1 (:$ 0)))
698  (bx lr))
699
700;;; This needs to be done out-of-line, to handle EGC memoization.
701(defarmlapfunction %store-node-conditional ((offset 0) (object arg_x) (old arg_y) (new arg_z))
702  (spjump .SPstore-node-conditional))
703
704#+notyet                                ; needs a subprim on ARM
705(defarmlapfunction %store-immediate-conditional ((offset 0) (object arg_x) (old arg_y) (new arg_z))
706  (vpop temp0)
707  (unbox-fixnum imm0 temp0)
708  (let ((current temp1))
709    @again
710    (lrarx current object imm0)
711    (cmpr current old)
712    (bne @lose)
713    (strcx. new object imm0)
714    (bne @again)
715    (isync)
716    (li arg_z (+ arm::t-offset (target-nil-value)))
717    (bx lr)
718    @lose
719    (li imm0 arm::reservation-discharge)
720    (strcx. rzero rzero imm0)
721    (li arg_z nil)
722    (bx lr)))
723
724(defarmlapfunction set-%gcable-macptrs% ((ptr arm::arg_z))
725  (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil)))
726  (add imm1 imm0 (:$ (arm::kernel-global gcable-pointers)))
727  @again
728  (ldrex arg_y (:@ imm1))
729  (str arg_y (:@ ptr (:$ arm::xmacptr.link)))
730  (strex imm0 ptr (:@ imm1))
731  (cmp imm0 (:$ 0))
732  (bne @again)
733  (bx lr))
734
735;;; Atomically increment or decrement the gc-inhibit-count kernel-global
736;;; (It's decremented if it's currently negative, incremented otherwise.)
737(defarmlapfunction %lock-gc-lock ()
738  (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil)))
739  (add imm1 imm0 (:$ (arm::kernel-global gc-inhibit-count)))
740  @again
741  (ldrex arg_y (:@ imm1))
742  (cmp arg_y (:$ 0))
743  (add arg_z arg_y '1)
744  (sublt arg_z arg_y '1)
745  @store
746  (strex imm0 arg_z (:@ imm1))
747  (cmp imm0 (:$ 0))
748  (bne @again)
749  (bx lr))
750
751;;; Atomically decrement or increment the gc-inhibit-count kernel-global
752;;; (It's incremented if it's currently negative, incremented otherwise.)
753;;; If it's incremented from -1 to 0, try to GC (maybe just a little.)
754(defarmlapfunction %unlock-gc-lock ()
755  (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil)))
756  (add imm1 imm0 (:$ (arm::kernel-global gc-inhibit-count)))
757  @again
758  (mov arg_x (:$ 0))
759  (ldrex arg_y (:@ imm1))
760  (cmp arg_y '-1)
761  (moveq arg_x arg_y)
762  (subgt arg_z arg_y '1)
763  (addle arg_z arg_y '1)
764  (strex imm0 arg_z (:@ imm1))
765  (cmp imm0 (:$ 0))
766  (bne @again)
767  (cmp arg_x '0)
768  (bxeq lr)
769  (mov imm0 (:$ arch::gc-trap-function-immediate-gc))
770  (uuo-gc-trap (:? al))
771  (bx lr))
772
773
774
775(defarmlapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z))
776  (spjump .SPatomic-incf-node))
777
778(defarmlapfunction %atomic-incf-ptr ((ptr arg_z))
779  (macptr-ptr imm1 ptr)
780  @again
781  (ldrex imm0 (:@ imm1))
782  (add imm0 imm0 (:$ 1))
783  (strex imm2 imm0 (:@ imm1))
784  (cmp imm2 (:$ 0))
785  (bne @again)
786  (box-fixnum arg_z imm0)
787  (bx lr))
788
789
790(defarmlapfunction %atomic-incf-ptr-by ((ptr arg_y) (by arg_z))
791  (macptr-ptr imm1 ptr)
792  @again
793  (ldrex imm0 (:@ imm1))
794  (add imm0 imm0 (:asr by (:$ arm::fixnumshift)))
795  (strex imm2 imm0 (:@ imm1))
796  (bne @again)
797  (box-fixnum arg_z imm0)
798  (bx lr))
799
800(defarmlapfunction %atomic-decf-ptr ((ptr arg_z))
801  (macptr-ptr imm1 ptr)
802  (dmb)
803  @again
804  (ldrex imm0 (:@ imm1))
805  (sub imm0 imm0 (:$ 1))
806  (strex imm2 imm0 (:@ imm1))
807  (cmp imm2 (:$ 0))
808  (bne @again)
809  (box-fixnum arg_z imm0)
810  (bx lr))
811
812(defarmlapfunction %atomic-decf-ptr-if-positive ((ptr arg_z))
813  (macptr-ptr imm1 ptr)
814  @again
815  (ldrex imm0 (:@ imm1))
816  (cmp imm0 (:$ 0))
817  (sub imm0 imm0 (:$ 1))
818  (beq @done)
819  (strex imm2 imm0 (:@ imm1))
820  (cmp imm2 (:$ 0))
821  (bne @again)
822  (box-fixnum arg_z imm0)
823  (bx lr)
824  @done
825  (clrex)
826  (box-fixnum arg_z imm0)
827  (bx lr))
828
829
830(defarmlapfunction %atomic-swap-ptr ((ptr arg_y) (newval arg_z))
831  (macptr-ptr imm1 ptr)
832  @again
833  (unbox-fixnum imm2 arg_z)
834  (ldrex imm0 (:@ imm1))
835  (strex imm2 imm2 (:@ imm1))
836  (cmp imm2 (:$ 0))
837  (bne @again)
838  (box-fixnum arg_z imm0)
839  (bx lr))
840
841;;; Try to store the fixnum NEWVAL at PTR, if and only if the old value
842;;; was equal to OLDVAL.  Return the old value
843(defarmlapfunction %ptr-store-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z))
844  (macptr-ptr imm0 ptr)
845  @again
846  (ldrex imm1 (:@ imm0))
847  (cmp imm1 (:asr expected-oldval (:$ arm::fixnumshift)))
848  (unbox-fixnum imm2 newval)
849  (bne @done)
850  (strex imm2 imm2 (:@ imm0))
851  (cmp imm2 (:$ 0))
852  (bne @again)
853  (dmb)
854  (box-fixnum arg_z imm1)
855  (bx lr)
856  @done
857  (clrex)
858  (box-fixnum arg_z imm1)
859  (bx lr))
860
861(defarmlapfunction %ptr-store-fixnum-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z))
862  (let ((address imm2)
863        (actual-oldval imm1))
864    (macptr-ptr address ptr)
865    @again
866    (ldrex actual-oldval (:@ address))
867    (cmp actual-oldval expected-oldval)
868    (bne @done)
869    (strex imm0 newval (:@ address))
870    (cmp imm0 (:$ 0))
871    (bne @again)
872    (mov arg_z actual-oldval)
873    (bx lr)
874    @done
875    (clrex)
876    (mov arg_z actual-oldval)
877    (bx lr)))
878
879
880
881
882(defarmlapfunction %macptr->dead-macptr ((macptr arg_z))
883  (check-nargs 1)
884  (mov imm0 (:$ arm::subtag-dead-macptr))
885  (strb imm0 (:@ macptr (:$ arm::misc-subtag-offset)))
886  (bx lr))
887
888#+notyet                                ;for different reasons
889(defarmlapfunction %%apply-in-frame ((catch-count imm0) (srv temp0) (tsp-count imm0) (db-link imm0)
890                                     (parent arg_x) (function arg_y) (arglist arg_z))
891  (check-nargs 7)
892
893  ; Throw through catch-count catch frames
894  (lwz imm0 12 vsp)                      ; catch-count
895  (vpush parent)
896  (vpush function)
897  (vpush arglist)
898  (sploadlr .SPnthrowvalues)
899  (blx lr)
900
901  ; Pop tsp-count TSP frames
902  (lwz tsp-count 16 vsp)
903  (cmpi cr0 tsp-count 0)
904  (b @test)
905@loop
906  (subi tsp-count tsp-count '1)
907  (cmpi cr0 tsp-count 0)
908  (lwz tsp 0 tsp)
909@test
910  (bne cr0 @loop)
911
912  ; Pop dynamic bindings until we get to db-link
913  (lwz imm0 12 vsp)                     ; db-link
914  (lwz imm1 arm::tcr.db-link arm::rcontext)
915  (cmp cr0 imm0 imm1)
916  (beq cr0 @restore-regs)               ; .SPunbind-to expects there to be something to do
917  (sploadlr .SPunbind-to)
918  (blx lr)
919
920@restore-regs
921  ; restore the saved registers from srv
922  (lwz srv 20 vsp)
923@get0
924  (svref imm0 1 srv)
925  (cmpwi cr0 imm0 (target-nil-value))
926  (beq @get1)
927  (lwz save0 0 imm0)
928@get1
929  (svref imm0 2 srv)
930  (cmpwi cr0 imm0 (target-nil-value))
931  (beq @get2)
932  (lwz save1 0 imm0)
933@get2
934  (svref imm0 3 srv)
935  (cmpwi cr0 imm0 (target-nil-value))
936  (beq @get3)
937  (lwz save2 0 imm0)
938@get3
939  (svref imm0 4 srv)
940  (cmpwi cr0 imm0 (target-nil-value))
941  (beq @get4)
942  (lwz save3 0 imm0)
943@get4
944  (svref imm0 5 srv)
945  (cmpwi cr0 imm0 (target-nil-value))
946  (beq @get5)
947  (lwz save4 0 imm0)
948@get5
949  (svref imm0 6 srv)
950  (cmpwi cr0 imm0 (target-nil-value))
951  (beq @get6)
952  (lwz save5 0 imm0)
953@get6
954  (svref imm0 7 srv)
955  (cmpwi cr0 imm0 (target-nil-value))
956  (beq @get7)
957  (lwz save6 0 imm0)
958@get7
959  (svref imm0 8 srv)
960  (cmpwi cr0 imm0 (target-nil-value))
961  (beq @got)
962  (lwz save7 0 imm0)
963@got
964
965  (vpop arg_z)                          ; arglist
966  (vpop temp0)                          ; function
967  (vpop parent)                         ; parent
968  (extract-lisptag imm0 parent)
969  (cmpi cr0 imm0 arm::tag-fixnum)
970  (if (:cr0 :ne)
971    ; Parent is a fake-stack-frame. Make it real
972    (progn
973      (svref sp %fake-stack-frame.sp parent)
974      (stwu sp (- arm::lisp-frame.size) sp)
975      (svref fn %fake-stack-frame.fn parent)
976      (stw fn arm::lisp-frame.savefn sp)
977      (svref temp1 %fake-stack-frame.vsp parent)
978      (stw temp1 arm::lisp-frame.savevsp sp)
979      (svref temp1 %fake-stack-frame.lr parent)
980      (extract-lisptag imm0 temp1)
981      (cmpi cr0 imm0 arm::tag-fixnum)
982      (if (:cr0 :ne)
983        ;; must be a macptr encoding the actual link register
984        (macptr-ptr loc-pc temp1)
985        ;; Fixnum is offset from start of function vector
986        (progn
987          (svref temp2 0 fn)        ; function vector
988          (unbox-fixnum temp1 temp1)
989          (add loc-pc temp2 temp1)))
990      (stw loc-pc arm::lisp-frame.savelr sp))
991    ;; Parent is a real stack frame
992    (mov sp parent))
993  (set-nargs 0)
994  (sploadlr .SPspreadargz)
995  (blx lr)
996  (spjump .SPtfuncallgen))
997
998
999
1000       
1001
1002
1003(defarmlapfunction %%save-application ((flags arg_y) (fd arg_z))
1004  (unbox-fixnum imm0 flags)
1005  (orr imm0 imm0 (:$ arch::gc-trap-function-save-application))
1006  (unbox-fixnum imm1 fd)
1007  (uuo-gc-trap (:? al))
1008  (bx lr))
1009
1010
1011
1012(defarmlapfunction %misc-address-fixnum ((misc-object arg_z))
1013  (check-nargs 1)
1014  (add arg_z misc-object (:$ arm::misc-data-offset))
1015  (bx lr))
1016
1017
1018(defarmlapfunction fudge-heap-pointer ((ptr arg_x) (subtype arg_y) (len arg_z))
1019  (check-nargs 3)
1020  (macptr-ptr imm1 ptr) ; address in macptr
1021  (add imm0 imm1 (:$ 9))     ; 2 for delta + 7 for alignment
1022  (bic imm0 imm0 (:$ 7))   ; Clear low three bits to align
1023  (rsb imm1 imm1 imm0)  ; imm1 = delta
1024  (strh imm1 (:@  imm0 (:$ -2)))     ; save delta halfword
1025  (unbox-fixnum imm1 subtype)  ; subtype at low end of imm1
1026  (orr imm1 imm1 (:lsl len (:$ (- arm::num-subtag-bits arm::fixnum-shift))))
1027  (str imm1 (:@ imm0 (:$ 0)))       ; store subtype & length
1028  (add arg_z imm0 (:$ arm::fulltag-misc)) ; tag it, return it
1029  (bx lr))
1030
1031
1032
1033(defarmlapfunction %%make-disposable ((ptr arg_y) (vector arg_z))
1034  (check-nargs 2)
1035  (sub imm0 vector (:$ arm::fulltag-misc)) ; imm0 is addr = vect less tag
1036  (ldrh imm1 (:@ imm0 (:$ -2)))   ; get delta
1037  (sub imm0 imm0 imm1)  ; vector addr (less tag)  - delta is orig addr
1038  (str imm0 (:@ ptr (:$ arm::macptr.address)))
1039  (bx lr))
1040
1041(defarmlapfunction %vect-data-to-macptr ((vect arg_y) (ptr arg_z))
1042  ;; put address of vect data in macptr.  For all vector types
1043  ;; other than DOUBLE-FLOAT (or vectors thereof), the first byte
1044  ;; of data is at ARM::MISC-DATA-OFFSET; for the double-float
1045  ;; types, it's at ARM::MISC-DFLOAT-OFFSET.
1046  (extract-subtag imm0 vect)
1047  (cmp imm0 (:$ arm::subtag-double-float-vector))
1048  (cmpne imm0 (:$ arm::subtag-double-float))
1049  (addne temp0 vect (:$ arm::misc-data-offset))
1050  (addeq temp0 vect (:$ arm::misc-dfloat-offset))
1051  (str temp0 (:@ arg_z (:$ arm::macptr.address)))
1052  (bx lr))
1053
1054(defarmlapfunction %ivector-from-macptr ((ptr arg_z))
1055  ;; Assuming that PTR points to the first byte of vector data
1056  ;; (in an ivector allocated on a stack or in foreign memory),
1057  ;; return the (tagged) ivector.  Crash and burn if the assumption
1058  ;; is incorrect.
1059  (macptr-ptr imm0 arg_z)
1060  (and imm1 imm0 (:$ arm::node-size))
1061  (eor imm1 imm1 (:$ arm::node-size))
1062  (add imm0 imm0 (:$ (- arm::fulltag-misc arm::node-size)))
1063  (sub arg_z imm0 imm1)
1064  (bx lr))
1065
1066(defun get-saved-register-values ()
1067  (values))
1068
1069(defarmlapfunction %current-db-link ()
1070  (ldr arg_z (:@ arm::rcontext (:$ arm::tcr.db-link)))
1071  (bx lr))
1072
1073(defarmlapfunction %no-thread-local-binding-marker ()
1074  (mov arg_z (:$ arm::subtag-no-thread-local-binding))
1075  (bx lr))
1076
1077
1078
1079;;; Should be called with interrupts disabled.
1080(defarmlapfunction %safe-get-ptr ((src arg_y) (dest arg_z))
1081  (check-nargs 2)
1082  (macptr-ptr imm0 src)
1083  (str imm0 (:@ arm::rcontext (:$ arm::tcr.safe-ref-address)))
1084  (ldr imm0 (:@ imm0 (:$ 0)))                     ; may fault
1085  (str imm0 (:@ dest (:$ arm::macptr.address)))
1086  (bx lr))
1087
1088
1089
1090;;; r13 contains thread context on Linux/Darwin PPC64.
1091;;; That's maintained in r2 on LinuxPPC32, and not maintained
1092;;; in a GPR on DarwinPPC32
1093#+huh
1094(defarmlapfunction %get-os-context ()
1095  #+ppc64-target (mov arg_z 13)
1096  #+linuxppc32-target (mov arg_z 2)
1097  #+darinppc32-target (mov arg_z 0)
1098  (bx lr))
1099
1100#+bad-idea
1101(defarmlapfunction %check-deferred-gc ()
1102  (ldr imm0 arm::tcr.flags arm::rcontext)
1103  (slri. imm0 imm0 (- (1- arm::nbits-in-word) (+ arch::tcr-flag-bit-pending-suspend arm::fixnumshift)))
1104  (li arg_z nil)
1105  (bgelr)
1106  (uuo_interr arch::error-propagate-suspend rzero)
1107  (li arg_z t)
1108  (bx lr))
1109
1110
1111
1112(defarmlapfunction %%tcr-interrupt ((target arg_z))
1113  (check-nargs 1)
1114  (uuo-kernel-service (:$  arch::error-interrupt))
1115  (box-fixnum arg_z imm0)
1116  (bx lr))
1117
1118(defarmlapfunction %suspend-tcr ((target arg_z))
1119  (check-nargs 1)
1120  (uuo-kernel-service (:$ arch::error-suspend))
1121  (mov arg_z 'nil)
1122  (cmp imm0 (:$ 0))
1123  (addne arg_z arg_z (:$ arm::t-offset))
1124  (bx lr))
1125
1126(defarmlapfunction %suspend-other-threads ()
1127  (check-nargs 0)
1128  (uuo-kernel-service (:$ arch::error-suspend-all))
1129  (mov arg_z 'nil)
1130  (cmp imm0 (:$ 0))
1131  (addne arg_z arg_z (:$ arm::t-offset))
1132  (bx lr))
1133
1134(defarmlapfunction %resume-tcr ((target arg_z))
1135  (check-nargs 1)
1136  (uuo-kernel-service (:$ arch::error-resume))
1137  (mov arg_z 'nil)
1138  (cmp imm0 (:$ 0))
1139  (addne arg_z arg_z (:$ arm::t-offset))
1140  (bx lr))
1141
1142(defarmlapfunction %resume-other-threads ()
1143  (check-nargs 0)
1144  (uuo-kernel-service (:$ arch::error-resume-all))
1145  (mov arg_z 'nil)
1146  (bx lr))
1147
1148(defarmlapfunction %kill-tcr ((target arg_z))
1149  (check-nargs 1)
1150  (uuo-kernel-service (:$ arch::error-kill))
1151  (mov arg_z 'nil)
1152  (cmp imm0 (:$ 0))
1153  (addne arg_z arg_z (:$ arm::t-offset))
1154  (bx lr))
1155
1156(defarmlapfunction pending-user-interrupt ()
1157  (mov temp0 (:$ 0))
1158  (ref-global arg_z arm::intflag)
1159  (set-global temp0 arm::intflag imm0)
1160  (bx lr))
1161
1162#+later
1163(progn
1164(defarmlapfunction %atomic-pop-static-cons ()
1165  (li imm0 (+ (target-nil-value) (arm::kernel-global static-conses)))
1166  @again
1167  (lrarx arg_z rzero imm0)
1168  (cmpri arg_z (target-nil-value))
1169  (beq @lose)
1170  (%cdr arg_y arg_z)
1171  (strcx. arg_y rzero imm0)
1172  (bne @again)
1173  (li imm0 (+ (target-nil-value) (arm::kernel-global free-static-conses)))
1174  @decf
1175  (lrarx imm1 rzero imm0)
1176  (subi imm1 imm1 '1)
1177  (strcx. imm1 rzero imm0)
1178  (bne @decf)
1179  (isync)
1180  (bx lr)
1181  @lose
1182  (li imm0 arm::reservation-discharge)
1183  (strcx. rzero rzero imm0)
1184  (bx lr))
1185
1186
1187
1188(defarmlapfunction %staticp ((x arg_z))
1189  (check-nargs 1)
1190  (ref-global temp0 static-cons-area)
1191  (ldr imm1 arm::area.low temp0)
1192  (sub imm0 x imm1)
1193  (ldr imm1 arm::area.ndnodes temp0)
1194  (srri imm0 imm0 arm::dnode-shift)
1195  (li arg_z nil)
1196  (sub imm1 imm1 imm0)
1197  (cmplri imm1 0)
1198  (la imm1 128 imm1)
1199  (blelr)
1200  (box-fixnum arg_z imm1)
1201  (bx lr))
1202
1203(defarmlapfunction %static-inverse-cons ((n arg_z))
1204  (check-nargs 1)
1205  (extract-lisptag imm0 arg_z)
1206  (cmpri imm0 0)
1207  (ref-global temp0 static-cons-area)
1208  (bne @fail)
1209  (la n '-128 n)
1210  (ldr imm0 arm::area.ndnodes temp0)
1211  (ldr imm1 arm::area.high temp0)
1212  (box-fixnum arg_y imm0)
1213  (sub imm1 imm1 n)
1214  (cmplr arg_z arg_y)
1215  (sub imm1 imm1 n)
1216  (bgt @fail)
1217  (la arg_z arm::fulltag-cons imm1)
1218  (ldr arg_y arm::cons.car arg_z)
1219  (cmpri arg_y arm::unbound-marker)
1220  (bnelr)
1221  @fail
1222  (li arg_z nil)
1223  (bx lr))
1224);#+later
1225
1226(defarmlapfunction xchgl ((newval arg_y) (ptr arg_z))
1227  (unbox-fixnum imm0 newval)
1228  @again
1229  (macptr-ptr imm2 ptr)
1230  (ldrex imm1 (:@ imm2))
1231  (strex imm2 imm0 (:@ imm2))
1232  (cmp imm2 (:$ 0))
1233  (bne @again)
1234  (dmb)
1235  (box-fixnum arg_z imm1)
1236  (bx lr))
1237
1238(defarmlapfunction %atomic-pop-static-cons ()
1239  (load-global-address imm0 arm::static-conses)
1240  (load-global-address imm2 arm::free-static-conses)
1241  @again
1242  (ldrex arg_z (:@ imm0))
1243  (cmp arg_z 'nil)
1244  (bxeq lr)
1245  (%cdr temp0 arg_z)
1246  (strex imm1 temp0 (:@ imm0))
1247  (cmp imm1 (:$ 0))
1248  (bne @again)
1249  @dec
1250  (ldrex imm0 (:@ imm2))
1251  (sub imm0 imm0 '1)
1252  (strex imm1 imm0 (:@ imm2))
1253  (cmp imm1 (:$ 0))
1254  (bne @dec)
1255  (dmb)
1256  (bx lr))
1257 
1258
1259; end of arm-misc.lisp
Note: See TracBrowser for help on using the repository browser.