source: branches/arm/level-0/ARM/arm-misc.lisp @ 13955

Last change on this file since 13955 was 13955, checked in by gb, 9 years ago

arm-misc.lisp: Need xchgl for ARM (used in futex-based locking.)
l0-misc.lisp: ROOM and aux functions: no tsp on ARM
vinsn.lisp: rename :conditional attribute to :predicatable.
arm-vinsns.lisp, arm2.lisp: replace COPY-FPR with all 4 single/double
variants. Use :predicatable attribute to avoid some conditional branches.
arm-asm.lisp, arm-disassemble.lisp: add, fix some instruction definitions.

File size: 23.5 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;;; Copy N bytes from pointer src, starting at byte offset src-offset,
23;;; to ivector dest, starting at offset dest-offset.
24;;; It's fine to leave this in lap.
25;;; Depending on alignment, it might make sense to move more than
26;;; a byte at a time.
27;;; Does no arg checking of any kind.  Really.
28
29(defarmlapfunction %copy-ptr-to-ivector ((src (* 1 arm::node-size) )
30                                         (src-byte-offset 0) 
31                                         (dest arg_x)
32                                         (dest-byte-offset arg_y)
33                                         (nbytes arg_z))
34  (let ((src-reg imm0)
35        (src-byteptr temp2)
36        (src-node-reg temp0)
37        (dest-byteptr imm2)
38        (val imm1)
39        (node-temp temp1))
40    (cmp nbytes (:$ 0))
41    (ldr src-node-reg (:@ vsp (:$ src)))
42    (macptr-ptr src-reg src-node-reg)
43    (ldr src-byteptr (:@ vsp (:$ src-byte-offset)))
44    (add src-reg src-reg (:asr src-byteptr (:$ arm::fixnumshift)))
45    (unbox-fixnum dest-byteptr dest-byte-offset)
46    (add dest-byteptr dest-byteptr (:$ arm::misc-data-offset))
47    (b @test)
48    @loop
49    (subs nbytes nbytes '1)
50    (ldrb val (:@+ src-reg (:$ 1)))
51    (strb val (:@ dest dest-byteptr))
52    (add dest-byteptr dest-byteptr (:$ 1))
53    @test
54    (bne  @loop)
55    (mov arg_z dest)
56    (add vsp vsp '2)
57    (bx lr)))
58
59(defarmlapfunction %copy-ivector-to-ptr ((src (* 1 arm::node-size))
60                                         (src-byte-offset 0)
61                                         (dest arg_x)
62                                         (dest-byte-offset arg_y)
63                                         (nbytes arg_z))
64  (ldr temp0 (:@ vsp (:$ src)))
65  (cmp nbytes (:$ 0))
66  (ldr imm0 (:@ vsp (:$ src-byte-offset)))
67  (unbox-fixnum imm0 imm0)
68  (add imm0 imm0 (:$ arm::misc-data-offset))
69  (macptr-ptr imm1 dest)
70  (add imm1 imm1 (:asr dest-byte-offset (:$ arm::fixnumshift)))
71  (b @test)
72  @loop
73  (subs nbytes nbytes '1)
74  (ldrb imm2 (:@ temp0 imm0))
75  (add imm0 imm0 (:$ 1))
76  (strb imm2 (:@+ imm1 (:$ 1)))
77  @test
78  (bne @loop)
79  (mov arg_z dest)
80  (add vsp vsp '2)
81  (bx lr))
82
83(defarmlapfunction %copy-ivector-to-ivector ((src 4) 
84                                             (src-byte-offset 0) 
85                                             (dest arg_x)
86                                             (dest-byte-offset arg_y)
87                                             (nbytes arg_z))
88  (let ((rsrc temp0)
89        (scaled-src-idx imm1)
90        (scaled-dest-idx imm2)
91        (val imm0)
92        (nwords dest-byte-offset))
93    (cmp nbytes (:$ 0))
94    (vpop1 scaled-src-idx)
95    (mov scaled-src-idx (:lsr scaled-src-idx (:$ arm::fixnumshift)))
96    (mov val scaled-src-idx)
97    (add scaled-src-idx scaled-src-idx (:$ arm::misc-data-offset))
98    (vpop1 rsrc)
99    (beq @done)
100    (cmp rsrc dest)
101    (mov scaled-dest-idx (:lsr dest-byte-offset (:$ arm::fixnumshift)))
102    (orr val val scaled-dest-idx)
103    (add scaled-dest-idx scaled-dest-idx (:$ arm::misc-data-offset))
104    (beq @SisD)
105    @fwd
106    (tst val (:$ 3))
107    (bne @loop)
108    ;; src and dest offsets are word-aligned. Copy words.
109    (b @wtest)
110    @words                              ; source and dest different - words
111    (sub nbytes nbytes '4) 
112    (ldr val (:@ rsrc scaled-src-idx))
113    (add scaled-src-idx scaled-src-idx '1)
114    (str val (:@ dest scaled-dest-idx))
115    (add scaled-dest-idx scaled-dest-idx '1)
116    @wtest
117    (cmp nbytes '4)
118    (bge @words)
119    (cmp nbytes '0)
120    (b @test)
121    @loop
122    (subs nbytes nbytes '1)
123    (ldrb val (:@ temp0 scaled-src-idx))
124    (add scaled-src-idx scaled-src-idx (:$ 1))
125    (strb val (:@ dest scaled-dest-idx))
126    (add scaled-dest-idx scaled-dest-idx (:$ 1))
127    @test
128    (bne  @loop)
129    @done
130    (mov arg_z dest)
131    (bx lr)
132
133    @SisD
134    (cmp scaled-src-idx scaled-dest-idx) ; cmp src and dest
135    (beq @done)
136    (bgt @fwd)
137
138 
139    ;; Copy backwards when src & dest are the same and we're sliding down
140    @bwd
141    (add scaled-src-idx scaled-src-idx (:lsr nbytes (:$ arm::fixnumshift)))
142    (add scaled-dest-idx scaled-dest-idx (:lsr nbytes (:$ arm::fixnumshift)))
143    @loop2
144    (sub scaled-src-idx scaled-src-idx (:$ 1))
145    (sub scaled-dest-idx scaled-dest-idx (:$ 1))
146    (subs nbytes nbytes '1)
147    (ldrb val (:@ rsrc scaled-src-idx))
148    (strb val (:@ dest scaled-dest-idx))
149    @test2
150    (bne @loop2)
151    (b @done)))
152
153
154 
155
156(defarmlapfunction %copy-gvector-to-gvector ((src (* 1 arm::node-size))
157                                             (src-element 0)
158                                             (dest arg_x)
159                                             (dest-element arg_y)
160                                             (nelements arg_z))
161  (ldr temp2 (:@ vsp (:$ src-element)))
162  (ldr temp0 (:@ vsp (:$ src)))
163  (add vsp vsp '2)
164  (cmp temp0 dest)
165  (add imm0 temp2 (:$ arm::misc-data-offset))
166  (add imm1 dest-element (:$ arm::misc-data-offset))
167  (bne @test)
168  ;; Maybe overlap, or maybe nothing to do.
169  (cmp temp2 dest-element)
170  (beq @done)                       ; same vectors, same offsets
171  (blt @back)                       ; copy backwards, avoid overlap
172  (b @test)
173  @loop
174  (ldr temp1 (:@ temp0 imm0))
175  (add imm0 imm0 '1)
176  (str temp1 (:@ dest imm1))
177  (add imm1 imm1 '1)
178  @test
179  (subs nelements nelements '1)
180  (bge @loop)
181  @done
182  (mov arg_z dest)
183  (bx lr)
184  @back
185  (add imm1 nelements imm1)
186  (add imm0 nelements imm0)
187  (b @back-test)
188  @back-loop
189  (sub imm0 imm0 '1)
190  (ldr temp1 (:@ temp0 imm0))
191  (sub imm1 imm1 '1)
192  (str temp1 (:@ dest imm1))
193  @back-test
194  (subs nelements nelements '1)
195  (bge @back-loop)
196  (mov arg_z dest)
197  (bx lr))
198 
199 
200
201(defarmlapfunction %heap-bytes-allocated ()
202  (ldr imm2 (:@ rcontext (:$ arm::tcr.last-allocptr)))
203  (ldr imm1 (:@ rcontext (:$ arm::tcr.total-bytes-allocated-high)))
204  (ldr imm0 (:@ rcontext (:$ arm::tcr.total-bytes-allocated-low)))
205  (cmp imm2 (:$ 0))
206  (sub imm2 imm2 allocptr)
207  (beq @go)
208  (cmp allocptr (:$ -8))
209  (beq @go)
210  (adds imm0 imm0 imm2)
211  (adc imm1 imm1 (:$ 0))
212  @go
213  (b .SPmakeu64))
214
215
216
217
218(defarmlapfunction values ()
219  (:arglist (&rest values))
220  (vpush-argregs)
221  (add temp0 nargs vsp)
222  (ba .SPvalues))
223
224;; It would be nice if (%setf-macptr macptr (ash (the fixnum value)
225;; ash::fixnumshift)) would do this inline.
226(defarmlapfunction %setf-macptr-to-object ((macptr arg_y) (object arg_z))
227  (check-nargs 2)
228  (trap-unless-xtype= arg_y arm::subtag-macptr)
229  (str arg_z (:@ arg_y (:$ arm::macptr.address)))
230  (bx lr))
231
232(defarmlapfunction %fixnum-from-macptr ((macptr arg_z))
233  (check-nargs 1)
234  (trap-unless-xtype= arg_z arm::subtag-macptr)
235  (ldr imm0 (:@ arg_z (:$ arm::macptr.address)))
236  (trap-unless-fixnum imm0)
237  (mov arg_z imm0)
238  (bx lr))
239
240(defarmlapfunction %%get-unsigned-longlong ((ptr arg_y) (offset arg_z))
241  (trap-unless-xtype= ptr arm::subtag-macptr)
242  (macptr-ptr imm1 ptr)
243  (unbox-fixnum imm2 offset)
244  (add imm2 imm2 imm1)
245  (ldr imm0 (:@ imm2 (:$ 0)))
246  (ldr imm1 (:@ imm2 (:$ 4)))
247  (ba .SPmakeu64))
248
249
250
251(defarmlapfunction %%get-signed-longlong ((ptr arg_y) (offset arg_z))
252  (trap-unless-xtype= ptr arm::subtag-macptr)
253  (macptr-ptr imm1 ptr)
254  (unbox-fixnum imm2 offset)
255  (add imm2 imm2 imm1)
256  (ldr imm0 (:@ imm2 (:$ 0)))           ;low
257  (ldr imm1 (:@ imm2 (:$ 1)))           ;high
258  (ba .SPmakes64))
259
260
261
262(defarmlapfunction %%set-unsigned-longlong ((ptr arg_x)
263                                            (offset arg_y)
264                                            (val arg_z))
265  (build-lisp-frame imm0)
266  (mov fn nfn)
267  (trap-unless-xtype= ptr arm::subtag-macptr) 
268  (bl .SPgetu64)
269  (macptr-ptr imm2 ptr)
270  (add imm2 imm2 (:asr offset (:$ arm::fixnumshift)))
271  (str imm0 (:@ imm2 (:$ 0)))
272  (str imm1 (:@ imm2 (:$ 4)))
273  (return-lisp-frame imm0))
274
275
276
277(defarmlapfunction %%set-signed-longlong ((ptr arg_x)
278                                          (offset arg_y)
279                                          (val arg_z))
280  (build-lisp-frame imm0)
281  (mov fn nfn)
282  (trap-unless-xtype= ptr arm::subtag-macptr)
283  (bl .SPgets64)
284  (macptr-ptr imm2 ptr)
285  (add imm2 imm2 (:asr offset (:$ arm::fixnumshift)))
286  (str imm0 (:@ imm2 (:$ 0)))
287  (str imm1 (:@ imm2 (:$ 4)))
288  (return-lisp-frame imm0))
289
290
291
292(defarmlapfunction interrupt-level ()
293  (ldr arg_z (:@ arm::rcontext (:$ arm::tcr.tlb-pointer)))
294  (ldr arg_z (:@ arg_z (:$ arm::interrupt-level-binding-index)))
295  (bx lr))
296
297
298
299
300(defarmlapfunction set-interrupt-level ((new arg_z))
301  (ldr imm1 (:@ arm::rcontext (:$ arm::tcr.tlb-pointer)))
302  (trap-unless-fixnum new)
303  (str new (:@ imm1 (:$ arm::interrupt-level-binding-index)))
304  (bx lr))
305
306
307
308(defarmlapfunction %current-tcr ()
309  (mov arg_z rcontext)
310  (bx lr))
311
312(defarmlapfunction %tcr-toplevel-function ((tcr arg_z))
313  (check-nargs 1)
314  (cmp tcr arm::rcontext)
315  (mov imm0 vsp)
316  (ldr temp0 (:@ tcr (:$ arm::tcr.vs-area)))
317  (ldr imm1 (:@ temp0 (:$ arm::area.high)))
318  (ldrne imm0 (:@ temp0 (:$ arm::area.active)))
319  (cmp imm1 imm0)
320  (moveq arg_z 'nil)
321  (ldrne arg_z (:@ imm1 (:$ (- arm::node-size))))
322  (bx lr))
323
324(defarmlapfunction %set-tcr-toplevel-function ((tcr arg_y) (fun arg_z))
325  (check-nargs 2)
326  (cmp tcr arm::rcontext)
327  (mov imm0 vsp)
328  (ldr temp0 (:@ tcr (:$ arm::tcr.vs-area)))
329  (ldr imm1 (:@ temp0 (:$ arm::area.high)))
330  (ldrne  imm0 (:@ temp0 (:$ arm::area.active)))
331  (cmp imm1 imm0)
332  (mov imm0 ($ 0))
333  (push1 imm0 imm1)
334  (streq imm1 (:@ temp0 (:$ arm::area.active)))
335  (streq imm1 (:@ tcr (:$ arm::tcr.save-vsp)))
336  (str fun (:@ imm1 (:$ 0)))
337  (bx lr))
338
339;;; This needs to be done out-of-line, to handle EGC memoization.
340(defarmlapfunction %store-node-conditional ((offset 0) (object arg_x) (old arg_y) (new arg_z))
341  (ba .SPstore-node-conditional))
342
343#+notyet                                ; needs a subprim on ARM
344(defarmlapfunction %store-immediate-conditional ((offset 0) (object arg_x) (old arg_y) (new arg_z))
345  (vpop temp0)
346  (unbox-fixnum imm0 temp0)
347  (let ((current temp1))
348    @again
349    (lrarx current object imm0)
350    (cmpr current old)
351    (bne @lose)
352    (strcx. new object imm0)
353    (bne @again)
354    (isync)
355    (li arg_z (+ arm::t-offset (target-nil-value)))
356    (bx lr)
357    @lose
358    (li imm0 arm::reservation-discharge)
359    (strcx. rzero rzero imm0)
360    (li arg_z nil)
361    (bx lr)))
362
363(defarmlapfunction set-%gcable-macptrs% ((ptr arm::arg_z))
364  (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil)))
365  (add imm1 imm0 (:$ (arm::kernel-global gcable-pointers)))
366  @again
367  (ldrex arg_y (:@ imm1))
368  (str arg_y (:@ ptr (:$ arm::xmacptr.link)))
369  (strex imm0 ptr (:@ imm1))
370  (cmp imm0 (:$ 0))
371  (bne @again)
372  (bx lr))
373
374;;; Atomically increment or decrement the gc-inhibit-count kernel-global
375;;; (It's decremented if it's currently negative, incremented otherwise.)
376(defarmlapfunction %lock-gc-lock ()
377  (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil)))
378  (add imm1 imm0 (:$ (arm::kernel-global gc-inhibit-count)))
379  @again
380  (ldrex arg_y (:@ imm1))
381  (cmp arg_y (:$ 0))
382  (add arg_z arg_y '1)
383  (sublt arg_z arg_y '1)
384  @store
385  (strex imm0 arg_z (:@ imm1))
386  (cmp imm0 (:$ 0))
387  (bne @again)
388  (bx lr))
389
390;;; Atomically decrement or increment the gc-inhibit-count kernel-global
391;;; (It's incremented if it's currently negative, incremented otherwise.)
392;;; If it's incremented from -1 to 0, try to GC (maybe just a little.)
393(defarmlapfunction %unlock-gc-lock ()
394  (mov imm0 (:$ (- arm::nil-value arm::fulltag-nil)))
395  (add imm1 imm0 (:$ (arm::kernel-global gc-inhibit-count)))
396  @again
397  (mov arg_x ($ 0))
398  (ldrex arg_y (:@ imm1))
399  (cmp arg_y '-1)
400  (moveq arg_x arg_y)
401  (subgt arg_z arg_y '1)
402  (addle arg_z arg_y '1)
403  (strex imm0 arg_z (:@ imm1))
404  (cmp imm0 ($ 0))
405  (bne @again)
406  (cmp arg_x '0)
407  (bxeq lr)
408  (mov imm0 (:$ arch::gc-trap-function-immediate-gc))
409  (uuo-gc-trap (:? al))
410  (bx lr))
411
412
413
414(defarmlapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z))
415  (ba .SPatomic-incf-node))
416
417(defarmlapfunction %atomic-incf-ptr ((ptr arg_z))
418  (macptr-ptr imm1 ptr)
419  @again
420  (ldrex imm0 (:@ imm1))
421  (add imm0 imm0 (:$ 1))
422  (strex imm2 imm0 (:@ imm1))
423  (cmp imm2 (:$ 0))
424  (bne @again)
425  (box-fixnum arg_z imm0)
426  (bx lr))
427
428
429(defarmlapfunction %atomic-incf-ptr-by ((ptr arg_y) (by arg_z))
430  (macptr-ptr imm1 ptr)
431  @again
432  (ldrex imm0 (:@ imm1))
433  (add imm0 imm0 (:asr by (:$ arm::fixnumshift)))
434  (strex imm2 imm0 (:@ imm1))
435  (bne @again)
436  (box-fixnum arg_z imm0)
437  (bx lr))
438
439(defarmlapfunction %atomic-decf-ptr ((ptr arg_z))
440  (macptr-ptr imm1 ptr)
441  @again
442  (ldrex imm0 (:@ imm1))
443  (sub imm0 imm0 (:$ 1))
444  (strex imm2 imm0 (:@ imm1))
445  (cmp imm2 (:$ 0))
446  (bne @again)
447  (box-fixnum arg_z imm0)
448  (bx lr))
449
450(defarmlapfunction %atomic-decf-ptr-if-positive ((ptr arg_z))
451  (macptr-ptr imm1 ptr)
452  @again
453  (ldrex imm0 (:@ imm1))
454  (cmp imm0 (:$ 0))
455  (sub imm0 imm0 (:$ 1))
456  (beq @done)
457  (strex imm2 imm0 (:@ imm1))
458  (cmp imm2 (:$ 0))
459  (bne @again)
460  (box-fixnum arg_z imm0)
461  (bx lr)
462  @done
463  (clrex)
464  (box-fixnum arg_z imm0)
465  (bx lr))
466
467
468(defarmlapfunction %atomic-swap-ptr ((ptr arg_y) (newval arg_z))
469  (macptr-ptr imm1 ptr)
470  @again
471  (unbox-fixnum imm2 arg_z)
472  (ldrex imm0 (:@ imm1))
473  (strex imm2 imm2 (:@ imm1))
474  (cmp imm2 (:$ 0))
475  (bne @again)
476  (box-fixnum arg_z imm0)
477  (bx lr))
478
479;;; Try to store the fixnum NEWVAL at PTR, if and only if the old value
480;;; was equal to OLDVAL.  Return the old value
481(defarmlapfunction %ptr-store-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z))
482  (macptr-ptr imm0 ptr)
483  @again
484  (ldrex imm1 (:@ imm0))
485  (cmp imm1 (:asr expected-oldval (:$ arm::fixnumshift)))
486  (unbox-fixnum imm2 newval)
487  (bne @done)
488  (strex imm2 imm2 (:@ imm0))
489  (cmp imm2 (:$ 0))
490  (bne @again)
491  (box-fixnum arg_z imm1)
492  (bx lr)
493  @done
494  (clrex)
495  (box-fixnum arg_z imm1)
496  (bx lr))
497
498(defarmlapfunction %ptr-store-fixnum-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z))
499  (let ((address imm2)
500        (actual-oldval imm1))
501    (macptr-ptr address ptr)
502    @again
503    (ldrex actual-oldval (:@ address))
504    (cmp actual-oldval expected-oldval)
505    (bne @done)
506    (strex imm0 newval (:@ address))
507    (cmp imm0 (:$ 0))
508    (bne @again)
509    (mov arg_z actual-oldval)
510    (bx lr)
511    @done
512    (clrex)
513    (mov arg_z actual-oldval)
514    (bx lr)))
515
516
517
518
519(defarmlapfunction %macptr->dead-macptr ((macptr arg_z))
520  (check-nargs 1)
521  (mov imm0 (:$ arm::subtag-dead-macptr))
522  (strb imm0 (:@ macptr (:$ arm::misc-subtag-offset)))
523  (bx lr))
524
525#+notyet                                ;for different reasons
526(defarmlapfunction %%apply-in-frame ((catch-count imm0) (srv temp0) (tsp-count imm0) (db-link imm0)
527                                     (parent arg_x) (function arg_y) (arglist arg_z))
528  (check-nargs 7)
529
530  ; Throw through catch-count catch frames
531  (lwz imm0 12 vsp)                      ; catch-count
532  (vpush parent)
533  (vpush function)
534  (vpush arglist)
535  (bla .SPnthrowvalues)
536
537  ; Pop tsp-count TSP frames
538  (lwz tsp-count 16 vsp)
539  (cmpi cr0 tsp-count 0)
540  (b @test)
541@loop
542  (subi tsp-count tsp-count '1)
543  (cmpi cr0 tsp-count 0)
544  (lwz tsp 0 tsp)
545@test
546  (bne cr0 @loop)
547
548  ; Pop dynamic bindings until we get to db-link
549  (lwz imm0 12 vsp)                     ; db-link
550  (lwz imm1 arm::tcr.db-link arm::rcontext)
551  (cmp cr0 imm0 imm1)
552  (beq cr0 @restore-regs)               ; .SPunbind-to expects there to be something to do
553  (bla .SPunbind-to)
554
555@restore-regs
556  ; restore the saved registers from srv
557  (lwz srv 20 vsp)
558@get0
559  (svref imm0 1 srv)
560  (cmpwi cr0 imm0 (target-nil-value))
561  (beq @get1)
562  (lwz save0 0 imm0)
563@get1
564  (svref imm0 2 srv)
565  (cmpwi cr0 imm0 (target-nil-value))
566  (beq @get2)
567  (lwz save1 0 imm0)
568@get2
569  (svref imm0 3 srv)
570  (cmpwi cr0 imm0 (target-nil-value))
571  (beq @get3)
572  (lwz save2 0 imm0)
573@get3
574  (svref imm0 4 srv)
575  (cmpwi cr0 imm0 (target-nil-value))
576  (beq @get4)
577  (lwz save3 0 imm0)
578@get4
579  (svref imm0 5 srv)
580  (cmpwi cr0 imm0 (target-nil-value))
581  (beq @get5)
582  (lwz save4 0 imm0)
583@get5
584  (svref imm0 6 srv)
585  (cmpwi cr0 imm0 (target-nil-value))
586  (beq @get6)
587  (lwz save5 0 imm0)
588@get6
589  (svref imm0 7 srv)
590  (cmpwi cr0 imm0 (target-nil-value))
591  (beq @get7)
592  (lwz save6 0 imm0)
593@get7
594  (svref imm0 8 srv)
595  (cmpwi cr0 imm0 (target-nil-value))
596  (beq @got)
597  (lwz save7 0 imm0)
598@got
599
600  (vpop arg_z)                          ; arglist
601  (vpop temp0)                          ; function
602  (vpop parent)                         ; parent
603  (extract-lisptag imm0 parent)
604  (cmpi cr0 imm0 arm::tag-fixnum)
605  (if (:cr0 :ne)
606    ; Parent is a fake-stack-frame. Make it real
607    (progn
608      (svref sp %fake-stack-frame.sp parent)
609      (stwu sp (- arm::lisp-frame.size) sp)
610      (svref fn %fake-stack-frame.fn parent)
611      (stw fn arm::lisp-frame.savefn sp)
612      (svref temp1 %fake-stack-frame.vsp parent)
613      (stw temp1 arm::lisp-frame.savevsp sp)
614      (svref temp1 %fake-stack-frame.lr parent)
615      (extract-lisptag imm0 temp1)
616      (cmpi cr0 imm0 arm::tag-fixnum)
617      (if (:cr0 :ne)
618        ;; must be a macptr encoding the actual link register
619        (macptr-ptr loc-pc temp1)
620        ;; Fixnum is offset from start of function vector
621        (progn
622          (svref temp2 0 fn)        ; function vector
623          (unbox-fixnum temp1 temp1)
624          (add loc-pc temp2 temp1)))
625      (stw loc-pc arm::lisp-frame.savelr sp))
626    ;; Parent is a real stack frame
627    (mov sp parent))
628  (set-nargs 0)
629  (bla .SPspreadargz)
630  (ba .SPtfuncallgen))
631
632
633
634       
635
636
637(defarmlapfunction %%save-application ((flags arg_y) (fd arg_z))
638  (unbox-fixnum imm0 flags)
639  (orr imm0 imm0 (:$ arch::gc-trap-function-save-application))
640  (unbox-fixnum imm1 fd)
641  (uuo-gc-trap (:? al))
642  (bx lr))
643
644
645
646(defarmlapfunction %misc-address-fixnum ((misc-object arg_z))
647  (check-nargs 1)
648  (add arg_z misc-object (:$ arm::misc-data-offset))
649  (bx lr))
650
651
652(defarmlapfunction fudge-heap-pointer ((ptr arg_x) (subtype arg_y) (len arg_z))
653  (check-nargs 3)
654  (macptr-ptr imm1 ptr) ; address in macptr
655  (add imm0 imm1 (:$ 9))     ; 2 for delta + 7 for alignment
656  (bic imm0 imm0 (:$ 7))   ; Clear low three bits to align
657  (rsb imm1 imm1 imm0)  ; imm1 = delta
658  (strh imm1 (:@  imm0 (:$ -2)))     ; save delta halfword
659  (unbox-fixnum imm1 subtype)  ; subtype at low end of imm1
660  (orr imm1 imm1 (:lsl len (:$ (- arm::num-subtag-bits arm::fixnum-shift))))
661  (str imm1 (:@ imm0 (:$ 0)))       ; store subtype & length
662  (add arg_z imm0 (:$ arm::fulltag-misc)) ; tag it, return it
663  (bx lr))
664
665
666
667(defarmlapfunction %%make-disposable ((ptr arg_y) (vector arg_z))
668  (check-nargs 2)
669  (sub imm0 vector (:$ arm::fulltag-misc)) ; imm0 is addr = vect less tag
670  (ldrh imm1 (:@ imm0 (:$ -2)))   ; get delta
671  (sub imm0 imm0 imm1)  ; vector addr (less tag)  - delta is orig addr
672  (str imm0 (:@ ptr (:$ arm::macptr.address)))
673  (bx lr))
674
675(defarmlapfunction %vect-data-to-macptr ((vect arg_y) (ptr arg_z))
676  ;; put address of vect data in macptr.  For all vector types
677  ;; other than DOUBLE-FLOAT (or vectors thereof), the first byte
678  ;; of data is at ARM::MISC-DATA-OFFSET; for the double-float
679  ;; types, it's at ARM::MISC-DFLOAT-OFFSET.
680  (extract-subtag imm0 vect)
681  (cmp imm0 (:$ arm::subtag-double-float-vector))
682  (cmpne imm0 (:$ arm::subtag-double-float))
683  (addne temp0 vect (:$ arm::misc-data-offset))
684  (addeq temp0 vect (:$ arm::misc-dfloat-offset))
685  (str temp0 (:@ arg_z (:$ arm::macptr.address)))
686  (bx lr))
687
688(defun get-saved-register-values ()
689  (values))
690
691(defarmlapfunction %current-db-link ()
692  (ldr arg_z (:@ arm::rcontext (:$ arm::tcr.db-link)))
693  (bx lr))
694
695(defarmlapfunction %no-thread-local-binding-marker ()
696  (mov arg_z (:$ arm::subtag-no-thread-local-binding))
697  (bx lr))
698
699
700
701;;; Should be called with interrupts disabled.
702(defarmlapfunction %safe-get-ptr ((src arg_y) (dest arg_z))
703  (check-nargs 2)
704  (macptr-ptr imm0 src)
705  (str imm0 (:@ arm::rcontext (:$ arm::tcr.safe-ref-address)))
706  (ldr imm0 (:@ imm0 (:$ 0)))                     ; may fault
707  (str imm0 (:@ dest (:$ arm::macptr.address)))
708  (bx lr))
709
710
711
712;;; r13 contains thread context on Linux/Darwin PPC64.
713;;; That's maintained in r2 on LinuxPPC32, and not maintained
714;;; in a GPR on DarwinPPC32
715#+huh
716(defarmlapfunction %get-os-context ()
717  #+ppc64-target (mov arg_z 13)
718  #+linuxppc32-target (mov arg_z 2)
719  #+darinppc32-target (mov arg_z 0)
720  (bx lr))
721
722#+bad-idea
723(defarmlapfunction %check-deferred-gc ()
724  (ldr imm0 arm::tcr.flags arm::rcontext)
725  (slri. imm0 imm0 (- (1- arm::nbits-in-word) (+ arch::tcr-flag-bit-pending-suspend arm::fixnumshift)))
726  (li arg_z nil)
727  (bgelr)
728  (uuo_interr arch::error-propagate-suspend rzero)
729  (li arg_z t)
730  (bx lr))
731
732
733
734(defarmlapfunction %%tcr-interrupt ((target arg_z))
735  (check-nargs 1)
736  (uuo-kernel-service (:$  arch::error-interrupt))
737  (box-fixnum arg_z imm0)
738  (bx lr))
739
740(defarmlapfunction %suspend-tcr ((target arg_z))
741  (check-nargs 1)
742  (uuo-kernel-service (:$ arch::error-suspend))
743  (mov arg_z 'nil)
744  (cmp imm0 (:$ 0))
745  (addne arg_z arg_z (:$ arm::t-offset))
746  (bx lr))
747
748(defarmlapfunction %suspend-other-threads ()
749  (check-nargs 0)
750  (uuo-kernel-service (:$ arch::error-suspend-all))
751  (mov arg_z 'nil)
752  (cmp imm0 (:$ 0))
753  (addne arg_z arg_z (:$ arm::t-offset))
754  (bx lr))
755
756(defarmlapfunction %resume-tcr ((target arg_z))
757  (check-nargs 1)
758  (uuo-kernel-service (:$ arch::error-resume))
759  (mov arg_z 'nil)
760  (cmp imm0 (:$ 0))
761  (addne arg_z arg_z (:$ arm::t-offset))
762  (bx lr))
763
764(defarmlapfunction %resume-other-threads ()
765  (check-nargs 0)
766  (uuo-kernel-service (:$ arch::error-resume-all))
767  (mov arg_z 'nil)
768  (bx lr))
769
770(defarmlapfunction %kill-tcr ((target arg_z))
771  (check-nargs 1)
772  (uuo-kernel-service (:$ arch::error-kill))
773  (mov arg_z 'nil)
774  (cmp imm0 (:$ 0))
775  (addne arg_z arg_z (:$ arm::t-offset))
776  (bx lr))
777
778(defarmlapfunction pending-user-interrupt ()
779  (mov temp0 (:$ 0))
780  (ref-global arg_z arm::intflag)
781  (set-global temp0 arm::intflag imm0)
782  (bx lr))
783
784#+later
785(progn
786(defarmlapfunction %atomic-pop-static-cons ()
787  (li imm0 (+ (target-nil-value) (arm::kernel-global static-conses)))
788  @again
789  (lrarx arg_z rzero imm0)
790  (cmpri arg_z (target-nil-value))
791  (beq @lose)
792  (%cdr arg_y arg_z)
793  (strcx. arg_y rzero imm0)
794  (bne @again)
795  (li imm0 (+ (target-nil-value) (arm::kernel-global free-static-conses)))
796  @decf
797  (lrarx imm1 rzero imm0)
798  (subi imm1 imm1 '1)
799  (strcx. imm1 rzero imm0)
800  (bne @decf)
801  (isync)
802  (bx lr)
803  @lose
804  (li imm0 arm::reservation-discharge)
805  (strcx. rzero rzero imm0)
806  (bx lr))
807
808
809
810(defarmlapfunction %staticp ((x arg_z))
811  (check-nargs 1)
812  (ref-global temp0 static-cons-area)
813  (ldr imm1 arm::area.low temp0)
814  (sub imm0 x imm1)
815  (ldr imm1 arm::area.ndnodes temp0)
816  (srri imm0 imm0 arm::dnode-shift)
817  (li arg_z nil)
818  (sub imm1 imm1 imm0)
819  (cmplri imm1 0)
820  (la imm1 128 imm1)
821  (blelr)
822  (box-fixnum arg_z imm1)
823  (bx lr))
824
825(defarmlapfunction %static-inverse-cons ((n arg_z))
826  (check-nargs 1)
827  (extract-lisptag imm0 arg_z)
828  (cmpri imm0 0)
829  (ref-global temp0 static-cons-area)
830  (bne @fail)
831  (la n '-128 n)
832  (ldr imm0 arm::area.ndnodes temp0)
833  (ldr imm1 arm::area.high temp0)
834  (box-fixnum arg_y imm0)
835  (sub imm1 imm1 n)
836  (cmplr arg_z arg_y)
837  (sub imm1 imm1 n)
838  (bgt @fail)
839  (la arg_z arm::fulltag-cons imm1)
840  (ldr arg_y arm::cons.car arg_z)
841  (cmpri arg_y arm::unbound-marker)
842  (bnelr)
843  @fail
844  (li arg_z nil)
845  (bx lr))
846);#+later
847
848(defarmlapfunction xchgl ((newval arg_y) (ptr arg_z))
849  (unbox-fixnum imm0 newval)
850  @again
851  (macptr-ptr imm2 ptr)
852  (ldrex imm1 (:@ imm2))
853  (strex imm2 imm0 (:@ imm2))
854  (cmp imm2 (:$ 0))
855  (bne @again)
856  (box-fixnum arg_z imm1)
857  (bx lr))
858                         
859
860; end of arm-misc.lisp
Note: See TracBrowser for help on using the repository browser.